Album
view release on metacpan or search on metacpan
script/album view on Meta::CPAN
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();
# Create the default style sheets, if necessary.
add_stylesheets();
# Copy images in place, rotate if necessary, and create the thumbnails.
prepare_images();
# Update cache.
update_cache();
my $cache_update = 0;
my $entries_per_page = $index_columns*$index_rows;
my $num_indexes = int(($num_entries - 1) / $entries_per_page) + 1;
my $fn = "img0000";
# Cleanup excess files.
for ( 0 ) {
my $excess = $fn++ . ".html";
unlink(d_medium($excess));
unlink(d_large($excess)) or last;
}
# Map file names to html pages. Start with 1 to match "image N of M".
my @htmllist;
for my $i ( 0 .. $num_entries-1 ) {
$htmllist[$i] = $fn++ . ".html";
}
# Cleanup excess files.
for (my $i = $num_entries ; ; $i++ ) {
my $excess = $fn++ . ".html";
unlink(d_medium($excess));
unlink(d_large($excess)) or last;
}
# Init formats.
init_formats();
# Write the individual pages.
write_image_pages();
# Write the index pages.
write_index_pages();
# Write the journal.
write_journal_pages();
# Create index icon.
create_index_icon();
# Final update, if needed.
update_cache() if $cache_update;
exit 0;
################ Subroutines ################
# Image types.
use constant T_JPG => 1;
use constant T_MPG => 2;
use constant T_VOICE => 3; # still image + sound
# Pseudo types.
use constant T_PSEUDO => 0;
script/album view on Meta::CPAN
$indent = " " x $indent;
my $res = "";
foreach ( split(/\n/, $doc) ) {
my $line = detab($_);
$line =~ s/^$indent//;
$res .= $line . "\n";
}
$res;
}
sub init_formats {
my $lib_common = $lib_common;
$lib_common .= "/" if $lib_common ne "";
my $did = 0;
my $load = sub {
my ($req, $data) = @_;
my $fmt = d_fmt($req);
if ( -s $fmt ) {
local($/);
open (my $fh, $fmt) || die("$fmt: $!\n");
$data = <$fh>;
close($fh);
}
elsif ( $externalize_formats ) {
unless ( $did ) {
my $fdir = d_fmt("");
$fdir =~ s/\/+$//;
unless ( -d $fdir ) {
print STDERR ("mkdir $fdir\n");
mkdir(d_fmt(""));
}
}
print STDERR ("Creating formats: ") if $verbose > 1 && !$did++;
print STDERR ("$req ") if $verbose > 1;
open (my $fh, '>', $fmt) || die("$fmt: $!\n");
print {$fh} $data;
close($fh);
}
$data =~ s/\$\{lib_common\}/$lib_common/g;
$data =~ s/^([ \t]+)/detab($1)/gem;
$data;
};
# Format for index pages (mostly).
#
# Variables:
#
# $title
# $ltop
# $rtop
# $vbuttons / $hbuttons
# $jscript
# $contents
$fmt_index_page = $load->("index.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/index.css">
<title>$title</title>
$jscript
</head>
<body>
<table>
<tr>
<td></td>
<td align='left'>
<p class='hdl'>
$ltop
</p>
</td>
<td align='right'>
<p class='hdr'>
$rtop
</p>
</td>
</tr>
<tr>
<td valign='top'>
$vbuttons
</td>
<td valign='top' colspan='2'>
$contents
</td>
</tr>
</table>
</body>
</html>
EOD
# Format for image pages (mostly).
#
# Variables:
#
# $title
# $ltop
# $rtop
# $vbuttons / $hbuttons
# $jscript
# $image
# $lbot
# $rbot
$fmt_image_page = $load->("image.fmt", heredoc(<<' EOD', 4));
<?xml version="1.0" encoding="iso-8859-15"?>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<title>$title</title>
<link rel="stylesheet" href="../${lib_common}css/$dir.css">
$jscript
</head>
<body>
<table>
<tr>
<td></td>
<td align='left' valign='top'>
<p class='hdl'>
$ltop
</p>
</td>
<td align='right' valign='top'>
<p class='hdr'>
$rtop
</p>
</td>
</tr>
<tr>
<td valign='top'>
$vbuttons
</td>
<td align='center' valign='top' colspan='2'>
$image
</td>
</tr>
<tr>
<td></td>
<td align='left' valign='top'>
<p class='ftl'>
$lbot
</p>
</td>
<td align='right' valign='top'>
<p class='ftr'>
$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) {
script/album view on Meta::CPAN
$t =~ s/</</g;
$t =~ s/>/>/g;
fixquotes($t);
} if $@;
goto &html;
}
sub htmln($) {
# Escape HTML sensitive characters, and turn newlines into <br>.
my $t = html(shift);
return '' unless $t;
$t =~ s/\n+/$br/go;
$t;
}
sub indent($$) {
# Shift contents to the right so it fits pretty.
my ($t, $n) = @_;
$n = " " x $n;
return $n unless $t;
$t = detab($t);
$t =~ s/\n+$//;
$t =~ s/\n/\n$n/g;
$t;
}
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->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 {
script/album view on Meta::CPAN
my @b = (
($dir eq "large" && $medium) ?
button("medium", "../medium/".$htmllist[$i], 1, 1) :
button("index", "../".ixname(int($i/$entries_per_page)), 1, 1),
button("first", $htmllist[0], 1, $i > 0),
button("prev", $htmllist[$prev] || "", 1, $prev >= 0),
button("next", $htmllist[$next] || "", 1, $next < $num_entries),
button("last", $htmllist[-1], 1, $i < $num_entries-1));
if ( $journal && exists $jnltags{$el->tag} ) {
my $page = "../journal/jnl" . $jnltags{$el->tag} . ".html#img".sprintf("%04d", $i+1);
push(@b, button("journal", $page, 1, 1));
$nav{jnl} = $page;
}
if ( $el->type == T_VOICE ) {
my $sound = $el->assoc_name;
push(@b, button("sound", "../large/$sound", 1, 1));
}
my $imglink;
if ( $dir eq "medium" ) {
if ( $mediumonly ) {
$imglink = img($file, alt => "[Image]", border => 2);
}
elsif ( $movie ) {
$imglink = "<a href='../large/" . $el->dest_name . "'>" .
img($file, alt => "[Click to play movie]", border => 2) .
"</a>";
$nav{down} = "../large/" . $el->dest_name;
}
else {
$imglink = "<a href='../large/".$htmllist[$i]."'>" .
img($file, alt => "[Click for bigger image]", border => 2) .
"</a>";
$nav{down} = "../large/" . $htmllist[$i];
}
}
else {
if ( $movie ) {
$imglink = "<a href='" . $el->dest_name . "'>" .
img($file, alt => "[Click to play movie]", border => 2) .
"</a>";
}
else {
$imglink = img($file, alt => "[Image]", border => 2);
}
$nav{up} = "../medium/" . $htmllist[$i];
}
my $auxright = htmln($el->dest_name);
my $s = size_info($el);
$auxright .= " ($s)" if $s;
$auxright .= " $creator" if $creator;
my $auxleft = htmln($el->tag || "");
my $it2 = $it;
if ( $el->Make ) { # EXIF info
$it2 = "<a href='#' class='info'>" . $it .
"<span>" .
"<table border='1' width='100%'>\n" .
restyle_exif($el) . "</table>\n" .
"</span></a>";
}
my $tt2 = $tt;
if ( $dir eq "medium" && $el->annotation ) {
my @a = UNIVERSAL::isa($el->annotation, "ARRAY")
? @{$el->annotation} : ($el->annotation);
my $t = "";
foreach ( reverse(@{$el->annotation}) ) {
next unless $_;
my $x = $_; # copy
$x = html($x) unless $x =~ /^</;
$t .= "<p>\n" if $t;
$t .= $x;
}
$tt2 = "<a href='#' class='info'>" . $tt .
"<span>" .
"<table border='1' width='100%'>\n" .
"<tr><td>$t</td></tr>" .
"</table>\n" .
"</span></a>" if $t;
}
update_if_needed(d_dest($dir, $htmllist[$i]),
process_fmt($dir eq "medium" ?
$fmt_medium_page :
$fmt_large_page,
title => $it,
dir => $dir,
ltop => $it2,
rtop => $tt2,
hbuttons => join("", @b),
vbuttons => join("$br\n", @b),
jscript => jscript(%nav),
image => $imglink,
lbot => $auxleft,
rbot => $auxright,
));
}
################ Index Pages ################
sub write_index_pages {
print STDERR ("Creating ", $num_indexes, " index page",
$num_indexes == 1 ? "" : "s", "\n") if $verbose > 1;
my $mod = 0;
for my $i ( 0 .. $num_indexes-1 ) {
write_index_page($i) && $mod++;
}
uptodate("index", $mod) if $verbose > 1;
# Cleanup excess indices.
for (my $i = $num_indexes ; ; $i++ ) {
unlink(d_dest("index$i.html")) or last;
}
}
sub write_index_page {
my ($x) = @_;
script/album view on Meta::CPAN
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;
}
a:active {
color: $RED; text-decoration: none;
}
EOD
add_stylesheet("index", heredoc(<<" EOD", 4));
\@import "common.css";
a.info {
position: relative; z-index: 24; background-color: $LGREY;
color: $BLACK; text-decoration:none;
}
a.info:hover {
z-index: 25; background-color: $LGREY;
}
a.info span {
display: none;
}
a.info:hover span {
display: block;
position: absolute; top: 2em; left: 2em; width: 25em;
border: 0px; background-color: $MGREY; color: $BLACK;
text-align: center;
}
table.outer {
background: #d0d0d0;
border-collapse: separate;
border-width: 2px; /* border=2 */
border-style: solid;
border-color: #e8e8e8 #727272 #727272 #e8e8e8;
border-spacing: 3px; /* cellspacing = 3 */
}
table.outer tr {
background: #e0e0e0;
}
table.outer td {
border-width: 1px;
border-style: solid;
border-color: #7c7c7c #f5f5f5 #f5f5f5 #7c7c7c;
}
table.inner {
border: outset 0px;
}
table.inner td {
border: inset 0px;
}
p.hdr {
font-size: 140%; font-weight: bold;
font-family: Verdana, Arial, Helvetica;
}
p.hdr a:link {
color: #000000; text-decoration: underline;
}
p.hdr a:visited {
color: #000000; text-decoration: underline;
}
p.hdr a:hover {
color: #FF0000; text-decoration: underline;
}
EOD
add_stylesheet("large", heredoc(<<" EOD", 4));
\@import "common.css";
a.info {
position: relative; z-index: 24; background-color: $DGREY;
color: $BLACK; text-decoration: none;
}
a.info:hover {
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("medium", heredoc(<<" EOD", 4));
\@import "common.css";
a.info {
position: relative; z-index: 24; background-color: $DGREY;
color:$BLACK; text-decoration:none;
}
a.info:hover {
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);
( run in 2.721 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )