App-MaMGal

 view release on metacpan or  search on metacpan

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

use Image::Magick;
use App::MaMGal::Exceptions;

sub child            { $_[0]->{path_name}.'/'.$_[1]     }
sub page_path        { $_[0]->{base_name}.'/index.html' }
sub thumbnail_path   { $_[0]->{base_name}.'/.mamgal-index.png'  }

sub init
{
	my $self = shift;
	$self->SUPER::init(@_);
	if ($self->{dir_name} eq '/' and ($self->{base_name} eq '/' or $self->{base_name} eq '.')) {
		$self->{path_name} = '/';
		$self->{base_name} = '/';
		$self->{is_root} = 1;
	} elsif (-e $self->child('.mamgal-root')) {
		$self->{is_root} = 1;
	}
}

sub set_root

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

sub _write_contents_to
{
	my $self = shift;
	my $code = shift;
	my $suffix = shift;
	# TODO: this will be an issue when mamgal goes multi-threaded
	my $tmp_name = $self->child('.mamgal-tmp');
	my $full_name = $self->child($suffix);
	$self->SUPER::_write_contents_to($code, $tmp_name, $full_name);
}

sub _side_length
{
	my $self = shift;
	my $picture_count = shift;

	# The montage is a visual clue that the object is a container.
	# Therefore ensure we do not get a 1x1 montage, because it would be
	# indistinguishable from a single image.

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

			$e
		} @entries
	];
	return @{$self->{elements}};
}

sub containers
{
	my $self = shift;
	return if $self->is_root;
	return $self->SUPER::containers(@_);
}

sub creation_time
{
	my $self = shift;

	my $spaces = join('', map { " " } $self->containers);

	my @elements = $self->elements;
	if (scalar @elements == 1) {

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

		return wantarray ? @{$self->{cct}} : $self->{cct}->[1] if exists $self->{cct};
		my ($oldest, $youngest) = (undef, undef);
		foreach my $t (map { $_->creation_time } @elements) {
			$oldest   = $t if not defined $oldest   or $oldest   > $t;
			$youngest = $t if not defined $youngest or $youngest < $t;
		}
		$self->{cct} = [$oldest, $youngest];
		return ($oldest, $youngest) if wantarray;
		return $youngest;
	}
	return $self->SUPER::creation_time;
}

# Returns the most recent of:
# - this directory inode's modification time
# - all of interesting elements' content modification time
sub content_modification_time
{
	my $self = shift;
	my %opts = @_;
	my $own = $self->SUPER::content_modification_time;
	return $own if $opts{only_own};
	my @elements;
	if ($opts{consider_interesting_only}) {
		@elements = $self->_all_interesting_elements;
	} else {
		@elements = $self->elements;
	}
	foreach my $i (@elements) {
		# Prevent doing a deep tree walk
		my $that = $i->content_modification_time(only_own => 1);

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

		)) {
			$self->logger->log_exception($@, $self->{path_name});
			$s = $self->_new_video_icon;
		} else {
			die $@;
		}
	}
	return $s;
}

sub thumbnail_path { $_[0]->SUPER::thumbnail_path.$thumbnail_extension }

1;

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

use strict;
use warnings;
use base 'App::MaMGal::Entry::Picture';
use Carp;
use Image::Magick;
use POSIX;

sub init
{
	my $self = shift;
	$self->SUPER::init(@_);
}

sub refresh_scaled_pictures
{
	my $self = shift;
	return $self->refresh_miniatures([$self->medium_dir, 800, 600], [$self->thumbnails_dir, 200, 150]);
}

sub image_info
{

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

	my $self = shift;
	my $i = Image::Magick->new;
	my $r;
	$r = $i->Read($self->{path_name}) and App::MaMGal::SystemException->throw(message => '%s: reading failed: %s', objects => [$self->{path_name}, $r]);
	return $i;
}

sub creation_time
{
	my $self = shift;
	my $info = $self->image_info or return $self->SUPER::creation_time(@_);
	return $info->creation_time || $self->SUPER::creation_time(@_);
}

1;

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

package App::MaMGal::MplayerWrapper::NotAvailableException;
use strict;
use warnings;
use Carp;

sub _initialize
{
	my $self = shift;
	croak "this exception does not accept arguments" if @_;
	$self->SUPER::_initialize(@_);
}

sub message
{
	my $self = shift;
	'mplayer is not available - films will not be represented by snapshots.'
}

package App::MaMGal::MplayerWrapper::ExecutionFailureException;
use strict;
use warnings;
use Carp;

sub _initialize
{
	my $self = shift;
	$self->SUPER::_initialize(@_);
	croak "This exception requires a message argument" unless $self->message;
	croak "Either one or three arguments are required" if $self->stdout xor $self->stderr;
}

package App::MaMGal::SystemException;
use strict;
use warnings;
use Carp;

sub _initialize
{
	my $self = shift;
	$self->SUPER::_initialize(@_);
	croak "This exception requires a message argument" unless $self->message;
	# zero-width negative look-ahead assertion: a percent not followed by percent
	my $placeholder_count = () = $self->message =~ /%(?!%)/g;
	my $object_count = $self->objects ? scalar @{$self->objects} : 0;
	croak "Message with $placeholder_count placeholders must be followed by this many arguments, not $object_count" unless $placeholder_count == $object_count;
}

sub interpolated_message
{
	my $self = shift;

t/070_unit_dir.t  view on Meta::CPAN

use Test::Files;
use Test::HTML::Content;
use lib 'testlib';
BEGIN { our @ISA = 'App::MaMGal::Unit::Entry::Dir' }

use App::MaMGal::TestHelper;
use File::stat;

sub class_setting : Test(startup) {
	my $self = shift;
	$self->SUPER::class_setting;
	$self->{test_file_name} = [qw(td empty)];
}

sub empty_dir_properties : Test(3) {
	my $self = shift;
	my $d = $self->{entry};
	ok(! $d->is_root,                           "Freshly created dir is not a root");
	dies_ok(sub { $d->neighbours_of_index(0) }, "No neighbours of first index in an empty dir, because there is no such index");
	dies_ok(sub { $d->neighbours_of_index(1) }, "No neighbours of second index in an empty dir, because there is no such index");
}

t/070_unit_dir.t  view on Meta::CPAN

use Test::Files;
use Test::HTML::Content;
use lib 'testlib';
BEGIN { our @ISA = 'App::MaMGal::Unit::Entry::Dir' }

use App::MaMGal::TestHelper;
use File::stat;

sub class_setting : Test(startup) {
	my $self = shift;
	$self->SUPER::class_setting;
	$self->{test_file_name} = [qw(td/more subdir)];
}

sub more_subdir_tests : Test(3) {
	my $self = shift;
	# test root and containers on a deeply nested dir
	my $deep_dir = $self->{entry};
	ok(! $deep_dir->is_root,                                           "Freshly created dir is not a root");
	is_deeply([map { $_->name } $deep_dir->containers], [qw(td more)], "Non-root directory has some container names, in correct order");
	is(scalar($deep_dir->elements), 4,                                 "td/more/subdir has 4 elements - lost+found is ignored");

t/070_unit_dir.t  view on Meta::CPAN

use Test::Files;
use Test::HTML::Content;
use lib 'testlib';
BEGIN { our @ISA = 'App::MaMGal::Unit::Entry::Dir' }

use App::MaMGal::TestHelper;
use File::stat;

sub class_setting : Test(startup) {
	my $self = shift;
	$self->SUPER::class_setting;
	$self->{test_file_name} = [qw(td root_dir)];
}

sub root_dir_tests : Test(2) {
	my $self = shift;
	# test root property on a dir already tagged as root
	my $rd = $self->{entry};
	ok($rd->is_root,                   "Freshly created root dir is root");
	is_deeply([($rd->containers)], [], "Root directory has no container names");
}

t/070_unit_dir.t  view on Meta::CPAN

use Test::Files;
use Test::HTML::Content;
use lib 'testlib';
BEGIN { our @ISA = 'App::MaMGal::Unit::Entry::Dir' }

use App::MaMGal::TestHelper;
use File::stat;

sub class_setting : Test(startup) {
	my $self = shift;
	$self->SUPER::class_setting;
	$self->{test_file_name} = [qw(/ bin)];
}

sub slash_bin_tests : Test(2) {
	my $self = shift;
	# test root properties on a absolutely referenced subdir of a root dir and its container
	my $bd = $self->{entry};
	ok(! $bd->is_root,          "Freshly created dir is not a root");
	ok($bd->container->is_root, "Toplevel dir's container is root");
}

t/070_unit_dir.t  view on Meta::CPAN

use Test::Files;
use Test::HTML::Content;
use lib 'testlib';
BEGIN { our @ISA = 'App::MaMGal::Unit::Entry::Dir' }

use App::MaMGal::TestHelper;
use File::stat;

sub class_setting : Test(startup) {
	my $self = shift;
	$self->SUPER::class_setting;
	$self->{test_file_name} = [qw(/ .)];
}

sub slash_tests : Test {
	my $self = shift;
	# test root property on the real "/" root
	my $Rd = $self->{entry};
	ok($Rd->is_root, "Freshly created root dir is root");
}

t/070_unit_dir.t  view on Meta::CPAN

use Test::Files;
use Test::HTML::Content;
use lib 'testlib';
BEGIN { our @ISA = 'App::MaMGal::Unit::Entry::Dir' }

use App::MaMGal::TestHelper;
use File::stat;

sub class_setting : Test(startup) {
	my $self = shift;
	$self->SUPER::class_setting;
	$self->{test_file_name} = [qw(. .)];
}

sub dot_dir_tests : Test(1) {
	my $self = shift;
	# test creation of the current directory
	my $cd = $self->{entry};
	ok(! $cd->is_root, "Freshly created root dir is not a root");
}

t/080_unit_picture.t  view on Meta::CPAN

sub stat_functionality : Test(1) {
	my $self = shift;
	$self->{mock_image_info}->mock('creation_time', sub { 1234567890 });
	is($self->{entry}->creation_time, 1234567890, 'if image info object returns a defined time, that time is returned');
}

sub stat_functionality_undefined : Test(2) {
	my $self = shift;
	$self->{mock_image_info}->mock('creation_time', sub { undef });
	# if image info object returns undef, we turn to the stat data supplied on creation
	$self->SUPER::stat_functionality;
}

sub stat_functionality_crashed : Test(6) {
	my $self = shift;
	$self->{mock_image_info_factory}->mock('read', sub { die "oh noes too!\n" });
	# if image info object construction fails, we turn to the stat data supplied on creation
	$self->{entry}->logger->clear;
	$self->SUPER::stat_functionality;
	logged_only_ok($self->{entry}->logger, qr{^Cannot retrieve image info: oh noes too!$}, 'td/c.jpg');
}

sub stat_functionality_when_created_without_stat : Test { ok(1) }

package App::MaMGal::Unit::Entry::Picture::Film;
use strict;
use warnings;
use Test::More;
use Test::Exception;

t/080_unit_picture.t  view on Meta::CPAN

sub class_setting : Test(startup) {
	my $self = shift;
	$self->{class_name} = 'App::MaMGal::Entry::Picture::Film';
	$self->{test_file_name} = [qw(td/one_film m.mov)];
}

sub relative_miniature_path
{
	my $self = shift;
	$self->SUPER::relative_miniature_path(@_).'.png'
}

sub _touch {
	my $self = shift;
	$self->SUPER::_touch(@_, '.png')
}

sub call_refresh_miniatures
{
	my $self = shift;
	$self->SUPER::call_refresh_miniatures(@_, '.png')
}

sub thumbnail_path_method : Test(2) {
	my $self = shift;
	my $class_name = $self->{class_name};
	my @test_file_name = $self->file_name;
	{
		my $e = $self->{entry};
		is($e->thumbnail_path, '.mamgal-thumbnails/'.$test_file_name[1].'.png', "$class_name thumbnail_path is correct");
	}