Image::Magick results from the CPAN

Album


# Development options (not shown with -help).
my $debug = 0;			# debugging
my $trace = 0;			# trace (show process)
my $test = 0;			# test mode.

# Process command line options.
app_options();

# Post-processing.
$trace |= ($debug || $test);
$dest_dir =~ s;^\./;;;
$import_dir =~ s;^\./;; if $import_dir;

################ Presets ################

use constant DEFAULTS => { info       => "info.dat",
			   title      => "Photo Album",
			   medium     => 0,
			   mediumsize => 915,
			   thumbsize  => 200,
			   indexrows  => 3,
			   indexcols  => 4,
			   caption    => "fct",
			   captionmin => "f",
			   dateformat => '%F',
			   icon	      => 0,
			 };

my $TMPDIR = $ENV{TMPDIR} || $ENV{TEMP} || '/usr/tmp';

my $picpat = qr{(?i:jpe?g|png|gif)};
my $movpat = qr{(?i:mpe?g|mov|avi)};
my $xtrpat = qw{(?i:html?)};
my $suffixpat = qr{\.$picpat|$movpat};
my $xsuffixpat = qr{\.$picpat|$movpat|$xtrpat};

my %capfun = ('c' => \&c_caption,
	      'f' => \&f_caption,
	      's' => \&s_caption,
	      't' => \&t_caption,
	     );

my $br = br();

# Max.number of clickable index numbers (should be odd).
use constant IXLIST => 15;

# Helper programs
my $prog_jpegtran  = findexec("jpegtran");
my $prog_mplayer   = findexec("mplayer");
my $prog_mencoder  = findexec("mencoder");

################ The Process ################

use File::Spec;
use File::Path;
use File::Basename;
use Time::Local;
use Image::Info;
use Image::Magick;
use Data::Dumper;
use POSIX qw(locale_h strftime);
use locale;

# The files already there, if any.
my $gotlist = new FileList;
# The files in the import dir, if any.
my $implist = new FileList;

# The list of files, in the order to be processed.
# This list is initialy filled from info.dat, and (optionally) updated
# from the other lists.
my $filelist = new FileList;

# This is the list of all entries to be journalled (all images, plus
# possible interspersed loose annotations).
my @journal;

# Load cached info, if possible.
load_cache();

# Load image names and info from the info file, if any.
# This produces the initial file list.
load_info();
#print STDERR Data::Dumper->Dump([$filelist],[qw(filelist)]);

# Load image names and info for files we already got.
load_files()  if -d d_large();
#print STDERR Data::Dumper->Dump([$gotlist],[qw(gotlist)]);

# Load image names and info for files we can import.
load_import() if $import_dir && -d $import_dir;
#print STDERR Data::Dumper->Dump([$implist],[qw(implist)]);

# Apply defaults to unset parameters.
set_defaults();

# warn("date => ", strftime($datefmt, localtime(time)), "\n");

# Verify and update the file list.
my $added = update_filelist();
#print STDERR Data::Dumper->Dump([$filelist],[qw(filelist)]);

my $num_entries = $filelist->tally;
print STDERR ("Number of entries = $num_entries",
	      $added ? " ($added added)" : "",
	      "\n") if $verbose > 1;
die("Nothing to do?\n") unless $num_entries > 0;
exit(0) if $test;

# Clean up and create directories.
if ( $clobber ) {
    rmtree([d_thumbnails(), d_medium()], $verbose > 1);
}
mkpath([d_large(), d_thumbnails(), d_icons(), d_css()], $verbose > 1);
mkpath([d_medium()], $verbose > 1) if $medium;

# Copy the button images over to the target directory.
add_button_images();

script/album view on Meta::CPAN

	print $fh ("!caption $caption\n")
	  if !$optcfg{"caption"} && $caption ne DEFAULTS->{caption};
    }
    print $fh ("\n# New entries added by $my_name $my_version, ".
	       localtime(time), "\n",
	       $newinfo,
	       "\n");
    close($fh);

    $new;
}

sub prepare_images {
    my $ddot = 0;
    my $tdot = 0;
    my $fmt = "[%" . length($filelist->tally) . "d]\n";
    my $msgfile;
    my $msg = sub {
	return unless $verbose > 1;

	if ( $verbose > 2 ) {
	    if ( $msgfile ) {
		print STDERR ("$msgfile: ");
		$msgfile = "";
	    }

	    print STDERR (@_ ? @_ : "OK\n");
	}

	unless ( @_ ) {
	    unless ( $msgfile ) {
		print STDERR ("OK\n");
		return;
	    }
	    print STDERR (".");
	    $tdot++;
	    if ( ++$ddot >= 50 ) {
		printf STDERR ($fmt, $tdot);
		$ddot = 0;
	    }
	    return;
	}

	printf STDERR ($fmt, $tdot) if $ddot;
	$ddot = 0;

	if ( $msgfile ) {
	    print STDERR ("$msgfile: ");
	    $msgfile = "";
	    $tdot++;
	}

	print STDERR (@_);
    };

    my $image;
    my $i_large;

    my $readimage = sub {
	my ($file) = (@_, $i_large);
	$image = new Image::Magick;
	my $t = $image->Read($file);
	warn("read($file): $t\n") if $t;
	#$image->Profile(name => "*", profile => undef);
    };

    my $resize = sub {
	 my ($n) = @_;
	 my ($origx, $origy) = $image->Get(qw(width height));
	 my $ratio = $origx > $origy ? $origx / $n : $origy / $n;
	 my $t = $image->Resize(width => $origx/$ratio, height => $origy/$ratio);
	 warn("resize: $t\n") if $t;
    };

    foreach my $el ( $filelist->entries ) {
	$msg->(), next unless $el->type > 0;
	my $file = $el->dest_name;
	$msgfile = $file;
	$image = undef;

	# Check for directory names, e.g. f01/p01.jpg.
	my $dn = dirname($file);
	if ( $dn && $dn ne "." ) { # we have a dir name.
	    mkpath([d_thumbnails($dn), d_large($dn)], 1);
	    mkpath([d_medium($dn)], 1) if $medium;
	}

	$i_large = d_large($file);
	my $movie = $el->type == T_MPG;

	# Copy the file into place.
	if ( ! -s $i_large && $el->orig_name ) {
	    my $i_src = $el->orig_name;
	    my $time = $el->timestamp;

	    if ( $movie ) {

		# Need copy?
		my $copyit = !$linkthem
		  || (($el->rotation || $el->mirror) && $prog_mencoder);

		# Try to link.
		if ( !$copyit ) {
		    $msg->("link ");
		    if ( link($i_src, $i_large) == 1 ) {
			# Ok, done.
		    }
		    else {
			# Need copy.
			unlink($i_large); # just in case
			$msg->("[copy] ");
			$copyit = 1;
		    }
		}
		else {
		    $msg->("copy");
		}

		# Need copy?
		if ( $copyit ) {
		    if ( $prog_mencoder ) {
			$msg->("/rotate (be patient)") if $el->rotation;
			$msg->(" ");
			# Currently. movies have a bad ugly copy routine...
			copy_mpg($i_src, $i_large, $time,
				 $el->rotation, $el->mirror);
		    }
		    else {
			$msg->(" [no rotation]") if $el->rotation;
			$msg->(" ");
			copy($i_src, $i_large, $time);
		    }
		}
	    }
	    elsif ( $el->rotation || $el->mirror ) {
		$msg->("copy");
		$msg->("/rotate") if $el->rotation;
		$msg->("/mirror") if $el->mirror;
		$msg->(" ");

		# Use jpegtran to rotate jpg files.
		if ( ($el->file_ext || "") eq "jpg" && $prog_jpegtran ) {
		    my $cmd = "$prog_jpegtran -copy all -rotate " . $el->rotation . " ";
		    $cmd .= $el->mirror eq 'h' ? "-transpose " : "-transverse "
		      if $el->mirror;
		    $cmd .= "-outfile " . squote($i_large) .
		      " " . squote($i_src);
		    my $t = `$cmd 2>&1`;
		    $msg->($t) if $t;
		    utime($time, $time, $i_large);
		}
		# Otherwise, let Image::Magick handle it.
		else {
		    $readimage->($i_src);
		    $image->Rotate();
		    if ( $el->mirror ) {
			$image->Flip if $el->mirror eq 'h';
			$image->Flop if $el->mirror eq 'v';
		    }
		    my $t = $image->Write($i_large);
		    $msg->($t) if $t;
		    utime($time, $time, $i_large);
		}
	    }
	    elsif ( $linkthem ) {
		$msg->("link ");
		unless ( link($i_src, $i_large) == 1 ) {
		    unlink($i_large); # just in case
		    $msg->("[copy] ");
		    copy($i_src, $i_large, $time);
		}
	    }
	    else {
		$msg->("copy ");
		copy($i_src, $i_large, $time);
	    }
	    if ( $el->type == T_VOICE ) {
		$msg->("sound ");
		copy_voice($i_src, d_large($el->assoc_name),
			   $time);
	    }
	}
	if ( $movie ) {
	    $movie = $file;
	    $file = $el->assoc_name;
	    $i_large = d_large($file);
	    unless ( -s $i_large ) {
		$msg->("still ");
		$image = still($el);
	    }
	}

	my $i_medium = d_medium($file);
	my $i_small  = d_thumbnails($file);

	if ( $medium && ! -s $i_medium ) {
	    $readimage->() unless $image;
	    $msg->("medium ");
	    $resize->($medium);
	    my $t = $image->Write($i_medium);
	    $msg->($t) if $t;
	}
	$el->medium_size(-s $i_medium) if $medium && !$movie;

	if ( ! -s $i_small ) {
	    $readimage->() unless $image;
	    $msg->("thumbnail ");
	    $resize->($thumb);
	    my $t = $image->Write($i_small);
	    $msg->($t) if $t;
	}

script/album view on Meta::CPAN

    $line .= " " x (8-length($line)%8) . shift(@l) while @l;

    $line;
}

################ Copying: plain files ################

sub copy {
    my ($orig, $new, $time) = @_;

    $time = (stat($orig))[9] unless defined($time);

    my $in = do { local *F; *F };
    open($in, "<", $orig) or die("$orig: $!\n");
    binmode($in);

    my $out = do { local *F; *F };
    open($out, ">", $new) or die("$new: $!\n");
    binmode($out);

    my $buf;

    for (;;) {
	my ($r, $w, $t);
	defined($r = sysread($in, $buf, 10240))
	  or die("$orig: $!\n");
	last unless $r;
	for ( $w = 0; $w < $r; $w += $t ) {
	    $t = syswrite($out, $buf, $r - $w, $w)
	      or die("$new: $!\n");
	}
    }
    close($in);
    close($out) or die("$new: $!\n");
    utime($time, $time, $new);
}

################ Copying: MPG files ################

sub copy_mpg {
    my ($orig, $new, $time, $rotate, $mirror) = @_;
    $time = (stat($orig))[9] unless defined($time);

    # I'm not sure what this does. The resultant file is about 10% of
    # the original, without missing something...
    my $cmd = "$prog_mencoder -of mpeg -oac copy -ovc ".
	($rotate ? "lavc -lavcopts vcodec=mpeg1video -vop rotate=".int($rotate/90)." " : "copy ") .
	  squote($orig) . " -o ". squote($new);
    warn("\n+ $cmd\n") if $verbose > 2;

    my $res = `$cmd 2>&1`;
    die("${res}Aborted\n") if $?;

    utime($time, $time, $new);
}

sub still {
    my ($el) = @_;

    my $new = d_large($el->assoc_name);
    my $still = new Image::Magick;
    if ( $prog_mplayer ) {
	my $tmp = "00000001.jpg";
	my $tmp2 = "00000002.jpg";
	if ( -e $tmp ) {
	    die("ERROR: mplayer needs to create a file $tmp, but it already exists!\n");
	}
	# Sometimes, -frames 1 does not produce anything. Need -frames 2.
	my $cmd = "$prog_mplayer -really-quiet -nojoystick -nolirc -nosound -frames 2 -vo jpeg " .
	  squote(d_large($el->dest_name));
	warn("\n+ $cmd\n") if $verbose > 2;
	my $t = `$cmd 2>&1`;
	warn("$t\n") unless -s $tmp;
	$still->Read($tmp);
	unlink($tmp, $tmp2);
    }
    else {
	# This may take minutes.
	$still->Read(d_large($el->dest_name)."[0]");
    }

    # Get still dimensions.
    my ($hs, $ws) = $still->Get(qw(height width));
    unless ( $hs && $ws ) {
	$still->Read(d_icons("movie.jpg"));
	$still->Write($new);
	return $still;
    }
    # Scale to 640x480 if needed.
    my $r = $hs > $ws ? 640 / $hs : 640 / $ws;
    if ( abs($r - 1) > 0.05 ) {
	$still->Resize(width => $r*$ws, height => $r*$hs);
	($hs, $ws) = $still->Get(qw(height width));
    }

    # Create black canvas.
    my $canvas = new Image::Magick;
    $canvas->Set(size => ($ws+240).'x'.($hs+180));
    $canvas->ReadImage('xc:black');
    my ($hc, $wc) = $canvas->Get(qw(height width));

    # Place the still on top of it.
    # Center image
    $canvas->Composite(image => $still, compose => 'Atop', x => 120, 'y' => 90);
    # Bottom slice.
    $canvas->Composite(image => $still, compose => 'Atop', x => 120, 'y' => $hs+135);
    # Top slice. Cannot place at negative offsets, so crop the still first.
    $still->Crop(width => $ws, height => 45, x => 0, 'y' => $hs-45);
    $canvas->Composite(image => $still, compose => 'Atop', x => 120, 'y' => 0);
    undef $still;

    # Drill spocket holes.
    my $hole = new Image::Magick;
    $hole->Set(size => '60x40');
    $hole->ReadImage("xc:grey90");
    $hole->Draw(primitive => 'polygon', fill => "black",
		points => " 0,0   5,0   0,5");
    $hole->Draw(primitive => 'polygon', fill => "black",
		points => "60,0  55,0  60,5");
    $hole->Draw(primitive => 'polygon', fill => "black",
		points => "60,40 55,40 60,35");
    $hole->Draw(primitive => 'polygon', fill => "black",
		points => " 0,40  5,40  0,35");

    for ( my $v = 0; $v < $hc;  $v += 80 ) {
	for my $h ( 30, $wc-90 ) {
	    $canvas->Composite(image => $hole, compose => 'Atop',
			    geometry => "+$h+$v");
	}
    }

    $canvas->Write($new);
    my $time = $el->timestamp;
    utime($time, $time, $new);
    $canvas;
}

################ Copying: Voice files ################

sub copy_voice {
    my ($orig, $new, $time) = @_;
    $time = (stat($orig))[9] unless defined($time);
    $orig =~ s/\.\w+$/.mpg/;
    return if -s $new;
    return unless $prog_mplayer;

    # This will produce an MP2 file. Good enough for now...
    my $cmd = "$prog_mplayer -nojoystick -nolirc -vo null ".
      "-dumpaudio -dumpfile " . squote($new) . " " . squote($orig);
    warn("\n+ $cmd\n") if $trace;
    my $res = `$cmd 2>&1`;
    die("${res}Aborted\n") if $?;
    die("${res}Aborted\n") unless -s $new;

    utime($time, $time, $new);
}

################ Index Icon Maintenance ################

sub create_index_icon {
    return unless $icon;
    print STDERR ("Creating index icon\n") if $verbose > 1;
    unless ( indexicon() ) {
	print STDERR ("(Index icon not modified)\n") if $verbose > 1;
    }
}

sub indexicon {
    my @imgs;
    for ( my $i = 0; $i < $index_rows*$index_columns; $i++ ) {
	next if $i >= $num_entries;
	my $el = $filelist->byseq($i+1);
	my $file = $el->dest_name;
	my $img;
	if ( $el->type == T_REF ) {
	    $img = $el->assoc_name;
	}
	else {
	    $img = $el->type == T_MPG ? $el->assoc_name : $file;
	    $img = "thumbnails/$img";
	}
	push(@imgs, $img);
    }

    my $iconfile = "icon.jpg";
    my $ii = cache_entry(" indexicon ");
    if ( -f $iconfile && $ii && $ii->dest_name eq "@imgs" ) {
	return 0;
    }
    my $el = new ImageInfo($iconfile);
    $el->dest_name("@imgs");
    cache_entry(" indexicon ", $el);
    $cache_update++;

    my $image = new Image::Magick->new;
    foreach ( @imgs ) {
	$image->Read($_);
    }

    my $width = $thumb;
    my $height = int($thumb*0.75);

    $image = $image->Montage(tile=>"${index_columns}x${index_rows}",
			     texture=>"xc:gray90");
    $image->Resize(geometry=>"${width}x${height}");
    $image->Write($iconfile);
    1;
}

################ Subroutines ################

sub app_options {
    my $help = 0;		# handled locally
    my $ident = 0;		# handled locally

    # Process options, if any.
    # Make sure defaults are set before returning!
    return unless @ARGV > 0;

    if ( !GetOptions(
	# Run time options.
	'clobber'        => \$clobber,
	'dcim=s'         => sub { $import_dir = $_[1]; $import_exif++ },
	'exif'           => \$import_exif,
	'import=s'       => \$import_dir,
	'info=s'         => \$info_file,
	'link!'          => \$linkthem,
	'update'         => \$update,
	'mediumonly'     => \$mediumonly,
	'extformats'	 => \$externalize_formats,

        # Album options. Can also be set in info/config files.
	'captions=s'     => \$caption,
	'cols|columns=i' => \$index_columns,
	'icon!'          => \$icon,
	'medium'         => sub { $medium = 0 },
	'mediumsize=i'   => \$medium,
	'rows=i'         => \$index_rows,
	'thumbsize=i'    => \$thumb,
	'title=s'        => \$album_title,

	# Miscellaneous.
	'debug'          => \$debug,
	'help|?'         => \$help,
	'ident'          => \$ident,
	'quiet'          => sub { $verbose = 0 },
	'test'           => \$test,
	'trace'          => \$trace,
	'verbose+'       => \$verbose,
        )
	 or $help
	 or @ARGV > 1
	 or @ARGV && ! -d $ARGV[0]
       )
    {

( run in 2.202 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )