Album
view release on metacpan or search on metacpan
script/album view on Meta::CPAN
#!/usr/bin/perl -w
my $RCS_Id = '$Id: album.pl,v 1.86 2007/04/02 09:07:50 jv Exp $ ';
# Author : Johan Vromans
# Created On : Tue Sep 15 15:59:04 2002
# Last Modified By: Johan Vromans
# Last Modified On: Mon Apr 2 11:07:05 2007
# Update Count : 2830
# Status : Unknown, Use with caution!
################ Common stuff ################
$VERSION = "1.06";
use strict;
# Package or program libraries, if appropriate.
# $LIBDIR = $ENV{'LIBDIR'} || '/usr/local/lib/sample';
# use lib qw($LIBDIR);
# require 'common.pl';
# Package name.
my $my_package = 'Sciurix';
# Program name and version.
my ($my_name, $my_version) = $RCS_Id =~ /: (.+).pl,v ([\d.]+)/;
# Tack '*' if it is not checked in into RCS.
$my_version .= '*' if length('$Locker: $ ') > 12;
my $creator = "Created with <a href=\"http://search.cpan.org/~jv/Album/\">Album</a> $::VERSION";
################ Command line parameters ################
use Getopt::Long 2.13;
# Command line options.
my $import_exif = 0;
my $import_dir;
my $update = 0; # add new from large/import
my $dest_dir = ".";
my $info_file;
my $linkthem = 1; # link orig to large, if possible
my $clobber = 0;
my $mediumonly = 0; # only medium size (for web export)
my $externalize_formats = 0; # create external format files
my $verbose = 1; # verbose processing
# These are left undefined, for set_defaults. Note: our, not my.
our $index_columns;
our $index_rows;
our $thumb;
our $medium; # medium size, between large and small
our $album_title;
our $caption;
our $datefmt;
our $icon;
our $locale;
our $lib_common;
# These are not command line options.
my $journal; # create journal
# 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,
script/album view on Meta::CPAN
# List of possible subdirs to process.
my @subdirs;
# Journal tags
my %jnltags;
# Note: the HTML generators use the file names relatively.
sub fjoin { File::Spec->catfile(@_); }
sub d_dest { unshift(@_, $dest_dir) unless $dest_dir eq ".";
fjoin(@_); }
sub d_large { unshift(@_, "large"); goto &d_dest; }
sub d_medium { unshift(@_, "medium"); goto &d_dest; }
sub d_thumbnails { unshift(@_, "thumbnails"); goto &d_dest; }
sub d_journal { unshift(@_, "journal"); goto &d_dest; }
sub d_destc { unshift(@_, $lib_common) if $lib_common ne ""; 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);
}
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));
}
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;
$medium = 0 if defined($medium) && $medium < 0;
# Caption values.
setopt("caption", DEFAULTS->{( -s $info_file || $import_dir) ?
"caption" : "captionmin" });
die("Invalid value for caption: $caption\n")
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, ">>", $info_file) || die("$info_file: $!\n");
unless ( $infosize ) {
print $fh ("# album control file created by Album $::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 $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;
script/album view on Meta::CPAN
$rbot
</p>
</td>
</tr>
</table>
</body>
</html>
EOD
$fmt_large_page = $load->("large.fmt", $fmt_image_page);
$fmt_medium_page = $load->("medium.fmt", $fmt_image_page);
# Format for journal pages (mostly).
#
# Variables:
#
# $title
# $tag
# $vbuttons / $hbuttons
# $journal
# $jscript
$fmt_journal_page = $load->("journal.fmt", heredoc(<<' EOD', 4));
<?xml version="1.0" encoding="iso-8859-15"?>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<link rel='stylesheet' href='../${lib_common}css/journal.css'>
<title>$title</title>
$jscript
</head>
<body>
<table class='outer'>
<tr class='grey'>
<td>
<p class='hd'>
$tag
</p>
</td>
<td align='right'>
$hbuttons
</td>
</tr>
$journal
<tr class='grey'>
<td> </td>
<td align='right'>
$hbuttons
</td>
</tr>
</table>
</body>
</html>
EOD
print STDERR ("\n") if $did;
}
sub process_fmt {
my ($fmt, %map) = @_;
$fmt =~ s/^(.*?)\$(\w+)\b/$1.indent($map{$2}, length($1))/gme;
$fmt;
}
################ Helpers for Image/Index/Journal pages ################
sub jscript {
my (%nav) = @_;
my $next = $nav{next};
my $prev = $nav{prev};
my $up = $nav{up};
my $down = $nav{down};
my $idx = $nav{idx};
my $jnl = $nav{jnl};
my $js = heredoc(<<" EOD", 4);
<script type='text/javascript'>
function handleKey(e) {
var key;
if ( e == null ) { // IE
key = event.keyCode
}
else { // Mozilla
if ( e.altKey || e.ctrlKey ) {
return true
}
key = e.which
}
switch(key) {
EOD
$js .= " case 8: window.location = '$prev'; break // Backspace\n" if $prev;
$js .= " case 32: window.location = '$next'; break // Space\n" if $next;
$js .= " case 13: window.location = '$down'; break // Enter\n" if $down;
$js .= " case 117: window.location = '$up'; break // 'u'\n" if $up;
$js .= " case 100: window.location = '$idx'; break // 'd'\n" if $idx;
$js .= " case 106: window.location = '$jnl'; break // 'j'\n" if $jnl;
$js .= heredoc(<<" EOD", 4);
default:
}
return false
}
document.onkeypress = handleKey
</script>
EOD
$js;
}
sub button($$;$$) {
my ($tag, $link, $level, $active) = @_;
my $Tag = ucfirst($tag);
$level = 0 unless defined $level;
$active = 1 unless defined $active;
$tag .= "-gr" unless $active;
$level = "../" x $level;
$level .= $lib_common . "/" if $lib_common ne "";
my $b = img("${level}icons/$tag.png", align => "top",
border => 0, alt => "[$Tag]");
$active ? "<a class='info' href='$link' alt='[$Tag]'>$b</a>" : $b;
script/album view on Meta::CPAN
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->DateTime;
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));
$app->("Aperture", sprintf("%.1f", $v))
if $v = $el->FNumber;
if ( $v = $el->FocalLength ) {
if ( $el->Model eq "DSC-V1" ) {
$v .= sprintf("mm (%.1fmm equiv.)", $v*4.857);
}
else {
$v .= "mm";
}
$app->("Focal length", $v);
}
$app->("ISO", $v) if $v = $el->ISOSpeedRatings;
$app->("Flash", $v)
if ($v = $el->Flash) && $v ne "Flash did not fire";
$app->("Metering", $v) if $v = $el->MeteringMode;
$app->("Scene", $v) if $v = $el->SceneCaptureType;
$app->("Camera",
join(" ", $v, $el->Model))
if $v = $el->Make;
}
#### Caption helpers.
sub f_caption($) {
my ($el) = @_;
my $s = htmln($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;
}
my $i = $el->seq - 1;
my $file = $el->dest_name;
my $rf = $file;
# Try movie.
my $movie = $el->type == T_MPG;
if ( $movie ) {
$file = $el->assoc_name;
}
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 ################
my $add_stylesheet_msg;
sub add_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";
$add_stylesheet_msg = 0;
add_stylesheet("common", heredoc(<<" EOD", 4));
body {
font-size: 80%; $css_fontfam;
text: $BLACK;
background: $DGREY;
}
td {
font-size: 80%; $css_fontfam;
}
p.hdl, p.hdr {
font-size: 140%; font-weight: bold;
$css_fontfam;
}
p.ftl, p.ftr {
font-size: 80%; $css_fontfam;
}
a:link {
color: $BLACK; text-decoration: none;
}
a:visited {
color: $BLACK; text-decoration: none;
script/album view on Meta::CPAN
z-index: 25; background-color: $DGREY;
}
a.info span {
display: none;
}
a.info:hover span {
display: block;
position: absolute; top:2em; left: 2em; width: 15em;
border: 0px; background-color: $MGREY; color: $BLACK;
text-align: center;
}
EOD
add_stylesheet("journal", heredoc(<<" EOD", 4));
body {
font-size: 100%; $css_fontfam;
text: $BLACK;
background: $WHITE;
}
p.hd {
font-size: 140%; font-weight: bold;
margin-left: 0.1in; margin-top: 0.1in; margin-bottom: 0.1in;
}
table.outer {
width: 500px;
border-spacing: 10px;
}
tr.grey {
background: $DGREY;
}
table.outer td {
}
EOD
print STDERR ("\n") if $add_stylesheet_msg;
}
sub add_stylesheet {
my ($css, $data) = @_;
return if -e d_css("$css.css");
print STDERR ("Creating style sheets: ")
unless $verbose <= 1 || $add_stylesheet_msg++;
print STDERR ("$css.css ");
$css = d_css("$css.css");
open(my $out, ">".$css) or die("$css: $!\n");
binmode($out);
print {$out} ($data);
close($out) or die("$css: $!\n");
}
################ End Style Sheets ################
sub detab {
my ($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 -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;
( run in 0.814 second using v1.01-cache-2.11-cpan-0d23b851a93 )