view release on metacpan or  search on metacpan

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

	my $self = shift;
	my $force = shift;
	my $formatter = $self->tools->{formatter};
	$self->_write_contents_to(sub { $formatter->format($self) }, 'index.html') unless ($self->fresher_than_me($self->child('index.html')) and not $force);
}

sub _write_stylesheet
{
	my $self = shift;
	if ($self->is_root) {
		my $formatter = $self->tools->{formatter};
		$self->_write_contents_to(sub { $formatter->stylesheet    }, '.mamgal-style.css');
	} else {
		# Delete legacy stylesheet files in directories other than root.
		# TODO: remove this code a few releases from 1.2
		my $path = $self->child('.mamgal-style.css');
		return unless -e $path;
		unlink($path) or App::MaMGal::SystemException->throw(message => '%s: unlink failed: %s', objects => [$path, $!]);
		return 1;
	}
}

sub ensure_subdir_exists
{
	my $self = shift;
	my $basename = shift;
	my $dir = $self->child($basename);
	mkdir $dir or App::MaMGal::SystemException->throw(message => '%s: mkdir failed: %s', objects => [$dir, $!]) unless -w $dir;
}

# get _picture_ neighbours of given picture
sub neighbours_of_index
{
	my $self = shift;
	my $idx  = shift;
	croak "neighbours_of_index must run in array context" unless wantarray;
	my @elements = $self->elements;
	$idx >= 0 or croak "Pic index must be at least 0";
	$idx < scalar @elements or croak "Pic index out of bounds for this dir";

	my ($prev, $next);
	my $i = $idx - 1;
	while ($i >= 0) {
		$prev = $elements[$i], last if $elements[$i]->isa('App::MaMGal::Entry::Picture');
		$i--;
	}
	$i = $idx + 1;
	while ($i < scalar @elements) {
		$next = $elements[$i], last if $elements[$i]->isa('App::MaMGal::Entry::Picture');
		$i++;
	}
	return $prev, $next;
}


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.
	my $sqrt = sqrt($picture_count);
	my $int = int($sqrt);
	my $side = $int == $sqrt ? $int : $int + 1;
	$side = 2 if $side < 2;
	return $side;
}

sub _write_montage
{
	my $self = shift;
	my $pruned_files = shift;

	my @images = $self->_all_interesting_elements;

	unless (@images) {
		$self->_write_contents_to(sub { App::MaMGal::DirIcon->img }, '.mamgal-index.png');
		return;
	}

	my $montage_path = $self->child('.mamgal-index.png');
	# Return early if the montage is fresh
	return if $self->fresher_than_me($montage_path, consider_interesting_only => 1) and $pruned_files == 0;

	# Get just a bunch of images, not all of them.
	my $montage_count = scalar @images > 36 ? 36 : scalar @images;
	# Stack them all together
	my $stack = Image::Magick->new;
	push @$stack, map {
		my $img = Image::Magick->new;
		my $rr;
		$rr = $img->Read($_->tile_path) and App::MaMGal::SystemException->throw(message => '%s: %s', objects => [$_->tile_path, $rr]);
		$img->[0] or $img } @images[0..($montage_count-1)];

	my $side = $self->_side_length($montage_count);

	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($)
{