Album
view release on metacpan or search on metacpan
script/album view on Meta::CPAN
# hjoin is used for generating html paths
sub hjoin { join("/", @_); }
# $fjoin will be dynamically switched depending on context.
our $fjoin; INIT { $fjoin = \&fjoin }
sub d_dest { unshift(@_, $dest_dir) unless $dest_dir eq ".";
$fjoin->(@_); }
sub d_index { unshift(@_, "index"); goto &d_dest; }
sub d_large { unshift(@_, "large"); goto &d_dest; }
sub d_medium { unshift(@_, "medium"); goto &d_dest; }
sub d_journal { unshift(@_, "journal"); goto &d_dest; }
sub d_up { unshift(@_, ".."); goto &d_dest; }
sub d_destc { unshift(@_, $lib_common) if $lib_common; goto &d_dest; }
sub d_icons { unshift(@_, "icons"); goto &d_destc; }
sub d_css { unshift(@_, "css"); goto &d_destc; }
sub d_fmt { unshift(@_, "formats"); goto &d_destc; }
my %optcfg; # option set from config files
sub setopt {
no strict qw(refs);
return if defined(${$_[0]});
print STDERR ("setopt $_[0] -> $_[1]\n") if $trace;
${$_[0]} = $_[1];
$optcfg{$_[0]} = 1;
}
sub parse_line {
local ($_) = (@_);
my $err = 0;
if ( /^!?\s*(\S.*)/ ) {
$_ = $1;
if ( /^title\s+(.*)/ ) {
setopt("album_title", $1);
}
elsif ( /^page\s+(\d+)x(\d+)/ ) {
setopt("index_rows", $1);
setopt("index_columns", $2);
}
elsif ( /^thumbsize\s*(\d+)/ ) {
setopt("thumb", $1);
}
elsif ( /^mediumsize\s*(\d+)(!)?/ ) {
setopt("medium", $1);
$forcemedium = defined $2;
}
elsif ( /^medium\s*(-?\d+)?/ ) {
setopt("medium", $1 || DEFAULTS->{mediumsize});
}
elsif ( /^dateformat\s*(.*)/ ) {
setopt("datefmt", $1);
}
elsif ( /^caption\s*(.*)/ ) {
setopt("caption", $1);
}
elsif ( /^icon\s*(.*)/ ) {
setopt("icon", defined($1) && length($1) ? $1 : 1);
}
elsif ( /^locale\s*(.*)/ ) {
setopt("locale", $1);
}
elsif ( /^depth\s+(\d+)/ ) {
# lib_common is used in the HTML, don't use fjoin.
setopt("lib_common", join("/", ("..") x $1));
}
elsif ( /^home\s+(.+)/ ) {
setopt("home_link", $1);
}
elsif ( /^skew\s+(.+)/ ) {
setopt("skew", $1);
}
else {
warn("Unknown control: $_[0]\n");
$err++;
}
}
else {
warn("Invalid control: $_[0]\n");
$err++;
}
$err;
}
sub set_defaults {
# Load settings from user files.
my $sl;
unless ( $sl = $ENV{ALBUMCONFIG} ) {
$sl = ".albumrc";
$sl .= ":".$ENV{HOME}."/.albumrc" if $ENV{HOME};
}
foreach my $cf ( split(/:/, $sl) ) {
unless ( -f $cf ) {
warn("$cf: $!\n") if $ENV{ALBUMCONFIG};
next;
}
open(my $fh, "<", $cf) || next;
warn("parsing: $cf\n") if $trace;
my $err = 0;
while ( <$fh> ) {
next if /^\s*#/;
next unless /\S/;
$err += parse_line($_);
}
close($fh);
die("Errors in config file $cf, aborted\n") if $err;
}
# Finally, apply defaults if necessary.
warn("apply defaults\n") if $trace;
setopt("album_title", DEFAULTS->{title});
setopt("index_rows", DEFAULTS->{indexrows});
setopt("index_columns", DEFAULTS->{indexcols});
setopt("thumb", DEFAULTS->{thumbsize});
setopt("datefmt", DEFAULTS->{dateformat});
setopt("icon", DEFAULTS->{icon});
$medium = DEFAULTS->{mediumsize} if defined($medium) && !$medium || $mediumonly;
script/album view on Meta::CPAN
($journal ? " \n\n" : " \n");
$el->tag($date) if $date;
$el->prev($prev->seq) if $prev;
$todo->add($el);
$prev->next($el->seq) if $prev;
$prev = $el unless $el->type == T_REF;
push(@journal, $el) if $journal;
$new++;
}
$filelist = $todo;
unless ( $new ) { # nothing to add
warn("No new images imported\n") if $verbose > 1;
return 0;
}
return $new if $test;
unless ( -w $info_file ) {
warn("$info_file: Cannot update (".
(-e _ ? "no write access" : "does not exist") .
")\n") if $verbose;
return $new;
}
my $infosize = -s $info_file;
# Append new info.
warn("Updating $info_file\n") if $verbose > 1;
my $fh = do { local *F; *F };
open($fh, $encoding ? ">>:encoding($encoding)" : ">>", $info_file) || die("$info_file: $!\n");
unless ( $infosize ) {
print $fh ("# album control file created by Album $my_version, ".
localtime(time), "\n\n");
print $fh ("!title $album_title\n") if $album_title;
if ( $medium && !$optcfg{"medium"} ) {
print $fh ($medium != DEFAULTS->{mediumsize} ?
"!mediumsize $medium\n" : "!medium\n");
}
print $fh ("!thumbsize $thumb\n")
if !$optcfg{"thumb"} && $thumb != DEFAULTS->{thumbsize};
print $fh ("!page ${index_rows}x${index_columns}\n")
if !$optcfg{index_rows} && $index_rows != DEFAULTS->{indexrows}
|| !$optcfg{index_columns} && $index_columns != DEFAULTS->{indexcols};
print $fh ("!caption $caption\n")
if !$optcfg{"caption"} && $caption ne DEFAULTS->{caption};
}
print $fh ("\n# New entries added by Album $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));
return unless $forcemedium || $origx > $n || $origy > $n;
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 ) {
script/album view on Meta::CPAN
</td>
</tr>
</table>
</body>
</html>
EOD
$format_for{large} = $load->("large.fmt", $format_for{image});
$format_for{medium} = $load->("medium.fmt", $format_for{image});
# Format for journal pages (mostly).
#
# Variables:
#
# $title
# $tag
# $vbuttons / $hbuttons
# $journal
# $jscript
$format_for{journal} = $load->("journal.fmt", heredoc(<<' EOD', 4));
<?xml version="1.0" encoding="iso-8859-15"?>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<!-- ALBUM-FMT-VERSION: 2.0 -->
<html>
<head>
<title>$title</title>
$css
$jscript
</head>
<body>
<table class='outer'>
<tr class='grey'>
<td>
<p class='hdl'>
$tag
</p>
</td>
<td class='buttons'>
$hbuttons
</td>
</tr>
$journal
<tr class='grey'>
<td></td>
<td class='buttons'>
$hbuttons
</td>
</tr>
</table>
</body>
</html>
EOD
print STDERR ("\n") if $did;
}
sub process_fmt {
my ($fmt, %map) = @_;
# THIS DOES ONLY ONE SUBST PER LINE
$fmt =~ s/^(.*?)\$(\w+)\b/$1.indent($map{$2}, length($1))/gme;
$fmt;
}
################ Style Sheets ################
my %css_for;
sub init_stylesheets {
my $css_fontfam = "font-family: Verdana, Arial, Helvetica";
my $WHITE = "#FFFFFF";
my $BLACK = "#000000";
my $RED = "#FF0000";
my $LGREY = "#E0E0E0";
my $MGREY = "#D0D0D0";
my $DGREY = "#C0C0C0";
my $DDGREY = "#B0B0B0";
my $BLUE = "#0000FF";
# Grey variants for index table borders.
my $GR245 = "#F5F5F5";
my $GR232 = "#E8E8E8";
my $GR124 = "#7C7C7C";
my $GR114 = "#727272";
my $helper = $thumb + 4;
my $did = 0;
my $load = sub {
my ($req, $data) = @_;
my $css = d_css($req.".css");
if ( -r $css ) {
my $major = $css_major;
my $minor = $css_minor;
my $orig;
if ( open(my $orig, "<", d_fmt("$req.fmt")) ) {
my $line = <$orig>;
close($orig);
if ( $line =~ m;/\*\s*album-fmt-version:\s*(\d+)\.(\d+)\s*\*/;i ) {
($major, $minor) = ($1, $2);
}
}
# Check stylesheet compatibility.
open($orig, "<", $css);
my $line = <$orig>;
close($orig);
if ( $line =~ m;/\*\s*album-css-version:\s*(\d+)\.(\d+)\s*\*/;i ) {
if ( $1 == $major ) {
return "";
}
}
print STDERR "\n" if $did;
die(heredoc(<<" EOD", 8));
*************************************************************************
Existing style sheet $req.css is not compatible with this version.
It has probably been created by an older version of this program, or it
has been modified manually.
If you did not change any style sheets, just remove the css directory and
try again.
script/album view on Meta::CPAN
}
sub img($%) {
my ($file, %atts) = @_;
my $ret = "<img src='" . $file . "'";
foreach ( sort(keys(%atts)) ) {
$ret .= " $_='" . $atts{$_} . "'";
}
$ret . "/>";
}
#### Size helpers.
sub bytes($) {
my $t = shift;
return $t . "b" if $t < 10*1024;
return ($t >> 10) . "kb" if $t < 10*1024*1024;
($t >> 20) . "Mb";
}
sub size_info($;$) {
my ($el, $med) = @_;
return unless $el->width;
my $ret = "";
$ret .= $el->width . "x" . $el->height if $el->width;
for ( $med ? $el->medium_size : $el->file_size ) {
next unless $_;
$ret .= "," if $ret;
$ret .= bytes($_);
}
$ret;
}
#### EXIF helpers.
sub restyle_exif($) {
my ($el) = @_;
my $ret = "";
my $v;
my $app = sub {
$ret .= "<tr><td>".htmln($_[0])."</td>".
"<td>".htmln($_[1])."</td></tr>\n";
};
$app->("Date", $v) if $v = $el->xDateTime;
my $t = $el->ExposureTime || 0;
# if ( $t && $t <= 0.5 ) {
# $t = "1/".int(0.5 + 1/$t)."s";
# }
$app->("Exposure",
join(" ", $el->ExposureMode || "",
$el->ExposureProgram || "", $t)) if $t;
$app->("Aperture", sprintf("%.1f", $v))
if $v = $el->FNumber;
if ( $v = $el->FocalLength ) {
if ( my $v2 = $el->FocalLengthIn35mmFormat ) {
$v .= " ($v2 eqv.)";
}
$app->("Focal length", $v);
}
$app->("ISO", $v) if $v = $el->ISOSpeedRatings;
$app->("Flash", $v)
if ($v = $el->Flash) && $v !~ /did not fire/i;
$app->("Metering", $v) if $v = $el->MeteringMode;
$app->("FocusMode", $v) if ($v = $el->FocusMode) && $v ne 'Auto';
$app->("WhiteBalance", $v) if ($v = $el->WhiteBalance) && $v ne 'Auto';
$app->("Scene", $v) if ($v = $el->SceneCaptureType) && $v ne 'Standard';
$app->("Camera", join(" ", $v, $el->Model)) if $v = $el->Make;
}
#### Caption helpers.
sub f_caption($) {
my ($el) = @_;
my $s = htmln($el->type == T_REF ? $el->orig_name : $el->dest_name);
if ( $el->Make ) {
$s = " $s<a href='#' class='info'> <span>".
"<table border='1' width='100%'>\n".
restyle_exif($el) . "</table>\n".
"</span></a>";
}
$s;
}
sub s_caption($) {
my ($el) = @_;
size_info($el, $medium);
}
sub t_caption($) {
my ($el) = @_;
$el->tag ? htmln($el->tag) : "";
}
sub c_caption($) {
my ($el) = @_;
my $t = $el->description || "";
$t =~ s/\n.*//;
htmln($t);
}
#### Misc.
sub update_if_needed($$) {
my ($fname, $new) = @_;
# Do not overwrite unless modified.
if ( -s $fname && -s _ == length($new) ) {
local($/);
my $hh = do { local *F; *F };
my $old;
open($hh, "<", $fname) && ($old = <$hh>) && close($hh);
if ( $old eq $new ) {
return 0;
}
}
my $fh = do { local *F; *F };
open($fh, ">", $fname)
or die("$fname (create): $!\n");
print $fh $new;
close($fh);
1;
}
sub uptodate($$) {
my ($type, $mod) = @_;
if ( $mod ) {
print STDERR ("(Needed to write ", $mod,
" $type page", $mod == 1 ? "" : "s", ")\n");
}
else {
print STDERR ("(No $type pages needed updating)\n");
}
}
################ Image Pages ################
sub write_image_pages {
print STDERR ("Creating ", $num_entries, " image page",
$num_entries == 1 ? "" : "s", "\n") if $verbose > 1;
my $mod = 0;
for my $el ( $filelist->entries ) {
write_image_page($el, "large") && $mod++;
write_image_page($el, "medium") && $mod++ if $medium;
}
uptodate("image", $mod) if $verbose > 1;
}
sub write_image_page {
my ($el, $dir) = @_;
if ( $el->type <= T_PSEUDO ) {
warn("PSEUDO: ", Dumper($el)) unless $el->type == T_REF;
return;
}
# Local scope...
my $orig_dd = $dest_dir;
local $dest_dir = ".";
local $fjoin = \&hjoin;
my $i = $el->seq - 1;
my $file = $el->dest_name;
my $rf = $file;
# Try movie.
my $movie = $el->type == T_MPG;
script/album view on Meta::CPAN
}
sub cache_entry {
if ( @_ == 1 ) {
$stats[0]++;
my $ii = $cache->entry(@_);
$stats[1]++ if $ii;
warn("Cache miss: $_[0]\n") if !$ii && $trace;
return $ii;
}
$stats[2]++;
$cache->entry(@_);
}
END {
print STDERR ("Cache: store = $stats[2], lookup = $stats[0], hits = $stats[1]\n")
if $trace;
}
}
#### Miscellaneous.
sub findexec {
my ($bin) = @_;
foreach ( File::Spec->path ) {
my $try = File::Spec->catfile($_, $bin);
return $try if -x $try;
}
undef;
}
sub squote {
my ($t) = @_;
$t =~ s/([\\\"])/\\$1/g;
$t = '"'.$t.'"' if $t =~ /[^-\w.\/]/;
$t;
}
################ Button Images ################
sub add_button_images {
# Extract button images from DATA section.
my $out = do { local *OUT; *OUT };
my $name;
my $doing = 0;
my $did = 0;
while ( <DATA> ) {
if ( $doing ) { # uudecoding...
if ( /^Xend/ ) {
close($out);
$doing = 0; # Done
next;
}
# Select lines to process.
next if /[a-z]/;
next unless /^X(.*)/s;
$_ = $1;
next unless int((((ord() - 32) & 077) + 2) / 3)
== int(length() / 4);
# Decode.
print $out unpack("u",$_);
next;
}
# Otherwise, search for the uudecode 'begin' line.
if ( /^Xbegin\s+\d+\s+(.+)$/ ) {
next if !$clobber && -s d_icons($1);
print STDERR ("Creating icons: ") if $verbose > 1 && !defined($name);
$did++;
$name = d_icons($1);
print STDERR ("$1 ") if $verbose > 1;
open($out, ">", $name);
binmode($out);
$doing = 1; # Doing
next;
}
}
print STDERR ("\n") if $verbose > 1;
if ( $doing ) {
die("Error in DATA: still processing $name\n");
unlink($name);
}
}
################ Style Sheets ################
################ End Style Sheets ################
sub detab {
my ($line) = @_;
return $line unless $line;
my $orig = $line;
my (@l) = split(/\t/, $line, -1);
# Replace tabs with blanks, retaining layout
$line = shift(@l);
$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 -vf 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;
( run in 0.936 second using v1.01-cache-2.11-cpan-6aa56a78535 )