App-MaMGal

 view release on metacpan or  search on metacpan

lib/App/MaMGal/Entry/Dir.pm  view on Meta::CPAN

	my ($m_x, $m_y) = (200, 150);

	my ($montage, $r);
	# Do the magick, scale and write.
	$r = $montage = $stack->Montage(tile => $side.'x'.$side, geometry => $m_x.'x'.$m_y, border => 2);
	ref($r)                                                            or  App::MaMGal::SystemException->throw(message => '%s: montage failed: %s',         objects => [$montage_path, $r]);
	$r = App::MaMGal::Entry::Picture->scale_into($montage, $m_x, $m_y) and App::MaMGal::SystemException->throw(message => '%s: scaling failed: %s',         objects => [$montage_path, $r]);
	$r = $montage->Write($montage_path)                                and App::MaMGal::SystemException->throw(message => '%s: writing montage failed: %s', objects => [$montage_path, $r]);
}

sub _ignorable_name($)
{
	my $self = shift;
	my $name = shift;
	# ignore hidden files
	return 1 if substr($_, 0, 1) eq '.';
	# TODO: optimize out contants calls, keeping in mind that they are not really constant (eg. tests change them when testing slides/miniatures generation)
	return 1 if grep { $_ eq $name } (qw(lost+found index.html .mamgal-index.png .mamgal-style.css), $self->slides_dir, $self->thumbnails_dir, $self->medium_dir);
	return 0;
}

lib/App/MaMGal/EntryFactory.pm  view on Meta::CPAN

	my $image_info_factory = shift or croak "Need an image info factory arg ";
	ref $image_info_factory and $image_info_factory->isa('App::MaMGal::ImageInfoFactory') or croak "Arg is not an App::MaMGal::ImageInfoFactory, but a [$image_info_factory]";
	my $logger = shift or croak "Need a logger arg ";
	ref $logger and $logger->isa('App::MaMGal::Logger') or croak "Arg is not a App::MaMGal::Logger , but a [$logger]";
	$self->{formatter} = $formatter;
	$self->{mplayer_wrapper} = $mplayer_wrapper;
	$self->{image_info_factory} = $image_info_factory;
	$self->{logger} = $logger;
}

sub sounds_like_picture($)
{
	my $base_name = shift;
	return $base_name =~ /\.(jpe?g|gif|png|tiff?|bmp)$/io;
}

sub sounds_like_film($)
{
	my $base_name = shift;
	return $base_name =~ /\.(mpe?g|mov|avi|mjpeg|m[12]v|wmv|fli|nuv|vob|ogm|vcd|svcd|mp4|qt|ogg)$/io;
}

sub canonicalize_path($)
{
	croak "List context required" unless wantarray;

	my $path = shift;

	# Do some path mangling in two special cases:
	if ($path eq '.') {
		# discover current directory name, so that it looks nice in
		# listings, and we know where to ascend when retracting towards
		# root directory

testlib/App/MaMGal/TestHelper.pm  view on Meta::CPAN

	$mmw->set_isa('App::MaMGal::MplayerWrapper');
	my $mock_image = Test::MockObject->new;
	$mock_image->set_isa('Image::Magick');
	$mock_image->mock('Get', sub { '100', '100' });
	$mock_image->mock('Scale', sub { undef });
	$mock_image->mock('Write', sub { system('touch', $_[1] ) });
	$mmw->mock('snapshot', sub { $mock_image });
	return $mmw;
}

sub get_mock_cc($) {
	my $ret = shift;
	my $mcc = Test::MockObject->new;
	$mcc->set_isa('App::MaMGal::CommandChecker');
	$mcc->mock('is_available', sub { $ret });
}

sub prepare_test_data {
	# We have to create empty directories, because git does not track them
	for my $dir (qw(empty one_dir one_dir/subdir more/subdir/lost+found)) {
		mkdir("td.in/$dir") or die "td.in/$dir: $!" unless -d "td.in/$dir";

testlib/App/MaMGal/TestHelper.pm  view on Meta::CPAN

	}
	# We also need to create our test symlinks, because MakeMaker does not like them
	for my $pair ([qw(td.in/symlink_broken broken)], [qw(td.in/symlink_pic_noext one_pic/a1.png)], [qw(td.in/symlink_to_empty empty)], [qw(td.in/symlink_to_empty_file empty_file)], [qw(td.in/symlink_pic.png one_pic/a1.png)]) {
		my ($link, $dest) = @$pair;
		symlink($dest, $link) or die "Failed to symlink [$dest] to [$link]" unless -l $link;
	}
	# Finally, purge and copy a clean version of the test data into "td"
	system('rm -rf td ; cp -a td.in td') == 0 or die "Test data preparation failed: $?";
}

sub logged_only_ok($$;$)
{
	my $mock = shift;
	my $re = shift;
	my $prefix = shift;
	my $level = $Test::Builder::Level;
	local $Test::Builder::Level = $level + 1;
	my ($name, $args) = $mock->next_call;
	is($name, 'log_message', 'expected method was called');
	like($args->[1], $re, 'message as expected');
	is($args->[2], $prefix, 'prefix as expected');
	($name, $args) = $mock->next_call;
	is($name, undef, 'no other logging method was called');
	return unless defined $name;
	is($args->[1], undef, 'no args were passed either');
	is($args->[2], undef, 'no args were passed either');
	is($args->[3], undef, 'no args were passed either');
}

sub printed_only_ok($$;$)
{
	my $mock = shift;
	my $re = shift;
	my $level = $Test::Builder::Level;
	local $Test::Builder::Level = $level + 1;
	my ($name, $args);
	if (ref $re and ref $re eq 'ARRAY') {
		foreach my $line_re (@$re) {
			($name, $args) = $mock->next_call;
			is($name, 'printf', "expected method was called (checking $line_re)");

testlib/App/MaMGal/TestHelper.pm  view on Meta::CPAN

		like((($args->[2] ? $args->[2] : '') . ($args->[3] ? $args->[3] : '')), $re, 'message as expected');
	}
	($name, $args) = $mock->next_call;
	is($name, undef, 'no other logging method was called');
	return unless defined $name;
	is($args->[1], undef, 'no args were passed either');
	is($args->[2], undef, 'no args were passed either');
	is($args->[3], undef, 'no args were passed either');
}

sub logged_exception_only_ok($$;$)
{
	my $mock = shift;
	my $ex = shift;
	my $prefix = shift;
	my $level = $Test::Builder::Level;
	local $Test::Builder::Level = $level + 1;
	my ($name, $args) = $mock->next_call;
	is($name, 'log_exception');
	is($args->[1], $ex);
	is($args->[2], $prefix);
	($name, $args) = $mock->next_call;
	is($name, undef, 'no other logging method was called');
	return unless defined $name;
	is($args->[1], undef, 'no args were passed either');
	is($args->[2], undef, 'no args were passed either');
	is($args->[3], undef, 'no args were passed either');
}

sub get_mock_exception($)
{
	my $class = shift;
	my $e = Test::MockObject->new;
	$e->set_isa($class);
	$e->mock('message', sub { 'foo bar' });
	$e->mock('interpolated_message', sub { 'foo bar baz' });
	return $e;
}

1;