97f1fbc51efbb192ec9b39a0baf1c87058df227a
[mkgallery.git] / mkgallery.pl
1 #!/usr/bin/perl
2
3 # $Id$
4
5 # Recursively create image gallery index and slideshow wrappings.
6 # Makes use of (slightly modified) "lightbox" Javascript/CSS as published
7 # at http://www.huddletogether.com/projects/lightbox/
8
9 # Copyright (c) 2006 Eugene G. Crosser
10
11 #  This software is provided 'as-is', without any express or implied
12 #  warranty.  In no event will the authors be held liable for any damages
13 #  arising from the use of this software.
14 #
15 #  Permission is granted to anyone to use this software for any purpose,
16 #  including commercial applications, and to alter it and redistribute it
17 #  freely, subject to the following restrictions:
18 #
19 #  1. The origin of this software must not be misrepresented; you must not
20 #     claim that you wrote the original software. If you use this software
21 #     in a product, an acknowledgment in the product documentation would be
22 #     appreciated but is not required.
23 #  2. Altered source versions must be plainly marked as such, and must not be
24 #     misrepresented as being the original software.
25 #  3. This notice may not be removed or altered from any source distribution.
26
27 package FsObj;
28
29 use strict;
30 use Carp;
31 use POSIX qw/getcwd/;
32 use CGI qw/:html *table *center *div/;
33 use Image::Info qw/image_info dim/;
34 use Term::ReadLine;
35 use Getopt::Long;
36
37 use Image::Magick;
38
39 my @sizes = (160, 640);
40
41 ######################################################################
42
43 my $debug = 0;
44 my $asktitle = 0;
45 my $noasktitle = 0;
46
47 GetOptions('asktitle'=>\$asktitle,
48                 'noasktitle'=>\$noasktitle,
49                 'debug'=>\$debug);
50
51 my $term = new Term::ReadLine "Edit Title";
52
53 FsObj->new(getcwd)->iterate;
54
55 sub new {
56         my $this = shift;
57         my $class;
58         my $self;
59         if (ref($this)) {
60                 $class = ref($this);
61                 my $parent = $this;
62                 my $name = shift;
63                 my $fullpath = $parent->{-fullpath}.'/'.$name;
64                 $self = {
65                                 -parent=>$parent,
66                                 -root=>$parent->{-root},
67                                 -base=>$name,
68                                 -fullpath=>$fullpath,
69                                 -inc=>'../'.$parent->{-inc},
70                         };
71         } else {
72                 $class = $this;
73                 my $root=shift;
74                 $self = {
75                                 -root=>$root,
76                                 -fullpath=>$root,
77                                 -inc=>getinc($root),
78                         };
79         }
80         bless $self, $class;
81         if ($debug) {
82                 print "new $class:\n";
83                 foreach my $k(keys %$self) {
84                         print "\t$k\t=\t$self->{$k}\n";
85                 }
86         }
87         return $self;
88 }
89
90 sub getinc {
91         my $fullpath=shift;     # this is not a method
92         my $depth=20;           # arbitrary max depth
93
94         my $inc=".include";
95         while ( ! -d $fullpath."/".$inc ) {
96                 $inc = "../".$inc;
97                 last unless ($depth-- > 0);
98         }
99         if ($depth > 0) {
100                 return $inc.'/';                # prefix with trailing slash
101         } else {
102                 return 'NO-.INCLUDE-IN-PATH/';  # won't work anyway
103         }
104 }
105
106 sub iterate {
107         my $self = shift;
108         my $fullpath .= $self->{-fullpath};
109         print "iterate in dir $fullpath\n" if ($debug);
110
111         my @rdirlist;
112         my @rimglist;
113         my $D;
114         unless (opendir($D,$fullpath)) {
115                 warn "cannot opendir $fullpath: $!";
116                 return;
117         }
118         while (my $de = readdir($D)) {
119                 next if ($de =~ /^\./);
120                 my $child = $self->new($de);
121                 if ($child->isdir) {
122                         push(@rdirlist,$child);
123                 } elsif ($child->isimg) {
124                         push(@rimglist,$child);
125                 }
126         }
127         closedir($D);
128         my @dirlist = sort {$a->{-base} cmp $b->{-base}} @rdirlist;
129         undef @rdirlist; # inplace sorting would be handy here
130         my @imglist = sort {$a->{-base} cmp $b->{-base}} @rimglist;
131         undef @rimglist; # optimize away unsorted versions
132         $self->{-firstimg} = $imglist[0];
133
134         print "Dir: $self->{-fullpath}\n" if ($debug);
135
136 # 1. first of all, fill title for this directory and create hidden subdirs
137
138         $self->initdir;
139
140 # 2. recurse into subdirectories to get their titles filled
141 #    before we start writing out subalbum list
142
143         foreach my $dir(@dirlist) {
144                 $dir->iterate;
145         }
146
147 # 3. iterate through images to build cross-links,
148
149         my $previmg = undef;
150         foreach my $img(@imglist) {
151                 # list-linking must be done before generating
152                 # aux html because aux pages rely on prev/next refs
153                 if ($previmg) {
154                         $previmg->{-nextimg} = $img;
155                         $img->{-previmg} = $previmg;
156                 }
157                 $previmg=$img;
158         }
159
160 # 4. create scaled versions and aux html pages
161
162         foreach my $img(@imglist) {
163                 # scaled versions must be generated before aux html
164                 # and main image index because they both rely on
165                 # refs to scaled images and they may be just original
166                 # images, this is not known before we try scaling.
167                 $img->makescaled;
168                 # finally, make aux html pages
169                 $img->makeaux;
170         }
171
172 # 5. start building index.html for the directory
173
174         $self->startindex;
175
176 # 6. iterate through subdirectories to build subalbums list
177
178         if (@dirlist) {
179                 $self->startsublist;
180                 foreach my $dir(@dirlist) {
181                         $dir->sub_entry;
182                 }
183                 $self->endsublist;
184         }
185
186 # 7. iterate through images to build thumb list
187
188         if (@imglist) {
189                 $self->startimglist;
190                 foreach my $img(@imglist) {
191                         print "Img: $img->{-fullpath}\n" if ($debug);
192                         $img->img_entry;
193                 }
194                 $self->endimglist;
195         }
196
197 # 8. comlplete building index.html for the directory
198
199         $self->endindex;
200 }
201
202 sub isdir {
203         my $self = shift;
204         return ( -d $self->{-fullpath} );
205 }
206
207 sub isimg {
208         my $self = shift;
209         my $fullpath = $self->{-fullpath};
210         return 0 unless ( -f $fullpath );
211         my $info = image_info($fullpath);
212         if (my $error = $info->{error}) {
213                 if (($error !~ "Unrecognized file format") &&
214                     ($error !~ "Can't read head")) {
215                         warn "File \"$fullpath\": $error\n";
216                 }
217                 return 0;
218         }
219         $self->{-isimg} = 1;
220         $self->{-info} = $info;
221         return 1;
222 }
223
224 sub initdir {
225         my $self = shift;
226         my $fullpath = $self->{-fullpath};
227         for my $subdir(@sizes, 'html') {
228                 my $tdir=sprintf "%s/.%s",$self->{-fullpath},$subdir;
229                 mkdir($tdir,0755) unless ( -d $tdir );
230         }
231         $self->edittitle;
232 }
233
234 sub edittitle {
235         my $self = shift;
236         my $fullpath = $self->{-fullpath};
237         my $title;
238         my $T;
239         if (open($T,'<'.$fullpath.'/.title')) {
240                 $title = <$T>;
241                 $title =~ s/[\r\n]*$//;
242                 close($T);
243         }
244         if ($asktitle || (!$title && !$noasktitle)) {
245                 my $prompt = $self->{-base};
246                 $prompt = '/' unless ($prompt);
247                 my $OUT = $term->OUT || \*STDOUT;
248                 print $OUT "Enter title for $fullpath\n";
249                 $title = $term->readline($prompt.' >',$title);
250                 $term->addhistory($title) if ($title);
251                 if (open($T,'>'.$fullpath.'/.title')) {
252                         print $T $title,"\n";
253                         close($T);
254                 }
255         }
256         unless ($title) {
257                 $title=substr($fullpath,length($self->{-root}));
258         }
259         $self->{-title}=$title;
260         print "title in $fullpath is $title\n" if ($debug);
261 }
262
263 sub makescaled {
264         my $self = shift;
265         my $fn = $self->{-fullpath};
266         my $name = $self->{-base};
267         my $dn = $self->{-parent}->{-fullpath};
268         my ($w, $h) = dim($self->{-info});
269         my $max = ($w > $h)?$w:$h;
270
271         foreach my $size(@sizes) {
272                 my $nref = '.'.$size.'/'.$name;
273                 my $nfn = $dn.'/'.$nref;
274                 my $factor=$size/$max;
275                 if ($factor >= 1) {
276                         $self->{$size} = $name; # unscaled version will do
277                 } else {
278                         $self->{$size} = $nref;
279                         if (isnewer($fn,$nfn)) {
280                                 doscaling($fn,$nfn,$factor,$w,$h);
281                         }
282                 }
283         }
284 }
285
286 sub isnewer {
287         my ($fn1,$fn2) = @_;                    # this is not a method
288         my @stat1=stat($fn1);
289         my @stat2=stat($fn2);
290         return (!@stat2 || ($stat1[9] > $stat2[9]));
291         # true if $fn2 is absent or is older than $fn1
292 }
293
294 sub doscaling {
295         my ($src,$dest,$factor,$w,$h) = @_;     # this is not a method
296         my $im = new Image::Magick;
297         my $err;
298         print "doscaling $src -> $dest by $factor\n" if ($debug);
299         $err = $im->Read($src);
300         unless ($err) {
301                 $im->Scale(width=>$w*$factor,height=>$h*$factor);
302                 $err=$im->Write($dest);
303                 warn "ImageMagick: write \"$dest\": $err" if ($err);
304         } else {        # fallback to command-line tools
305                 warn "ImageMagick: read \"$src\": $err";
306                 system("djpeg \"$src\" | pnmscale \"$factor\" | cjpeg >\"$dest\"");
307         }
308         undef $im;
309 }
310
311 sub makeaux {
312         my $self = shift;
313         my $name = $self->{-base};
314         my $dn = $self->{-parent}->{-fullpath};
315         my $pref = $self->{-previmg}->{-base};
316         my $nref = $self->{-nextimg}->{-base};
317         my $inc = $self->{-inc};
318         my $title = $self->{-info}->{'Comment'};
319         $title = $name unless ($title);
320
321         print "slide: \"$pref\"->\"$name\"->\"$nref\"\n" if ($debug);
322
323         # slideshow
324         for my $refresh('static', 'slide') {
325                 my $fn = sprintf("%s/.html/%s-%s.html",$dn,$name,$refresh);
326                 my $imgsrc = sprintf("../.%s/%s",$sizes[1],$name);
327                 my $fwdref;
328                 my $bakref;
329                 if ($nref) {
330                         $fwdref = sprintf("%s-%s.html",$nref,$refresh);
331                 } else {
332                         $fwdref = '../index.html';
333                 }
334                 if ($pref) {
335                         $bakref = sprintf("%s-%s.html",$pref,$refresh);
336                 } else {
337                         $bakref = '../index.html';
338                 }
339                 my $toggleref;
340                 my $toggletext;
341                 if ($refresh eq 'slide') {
342                         $toggleref=sprintf("%s-static.html",$name);
343                         $toggletext = 'Stop!';
344                 } else {
345                         $toggleref=sprintf("%s-slide.html",$name);
346                         $toggletext = 'Play-&gt;';
347                 }
348                 my $F;
349                 unless (open($F,'>'.$fn)) {
350                         warn "cannot open \"$fn\": $!";
351                         next;
352                 }
353                 if ($refresh eq 'slide') {
354                         print $F start_html(-title=>$title,
355                                         -bgcolor=>"#808080",
356                                         -head=>meta({-http_equiv=>'Refresh',
357                                                 -content=>"3; url=$fwdref"}),
358                                         -style=>{-src=>$inc."gallery.css"},
359                                 ),"\n";
360                                         
361                 } else {
362                         print $F start_html(-title=>$title,
363                                         -bgcolor=>"#808080",
364                                         -style=>{-src=>$inc."gallery.css"},
365                                 ),"\n";
366                 }
367                 print $F start_center,"\n",
368                         h1($title),
369                         a({-href=>"../index.html"},"Index")," | ",
370                         a({-href=>$bakref},"&lt;&lt;Prev")," | ",
371                         a({-href=>$toggleref},$toggletext)," | ",
372                         a({-href=>$fwdref},"Next&gt;&gt;"),
373                         p,
374                         img({-src=>$imgsrc}),"\n",
375                         end_center,"\n",
376                         end_html,"\n";
377                 close($F);
378         }
379 }
380
381 sub startindex {
382         my $self = shift;
383         my $fn = $self->{-fullpath}.'/index.html';
384         my $IND;
385         unless (open($IND,'>'.$fn)) {
386                 warn "cannot open $fn: $!";
387                 return;
388         }
389         $self->{-IND} = $IND;
390
391         my $inc = $self->{-inc};
392         my $title = $self->{-title};
393         print $IND start_html(-title => $title,
394                         -style=>{-src=>[$inc."gallery.css",
395                                         $inc."lightbox.css"]},
396                         -script=>[{-code=>"var incPrefix='$inc';"},
397                                 {-src=>$inc."gallery.js"},
398                                 {-src=>$inc."lightbox.js"}]),
399                 a({-href=>"../index.html"},"UP"),"\n",
400                 start_center,"\n",
401                 h1($title),"\n",
402                 "\n";
403 }
404
405 sub endindex {
406         my $self = shift;
407         my $IND = $self->{-IND};
408
409         print $IND end_center,end_html,"\n";
410
411         close($IND) if ($IND);
412         undef $self->{-IND};
413 }
414
415 sub startsublist {
416         my $self = shift;
417         my $IND = $self->{-IND};
418
419         print $IND h2("Albums"),"\n",start_table,"\n";
420 }
421
422 sub sub_entry {
423         my $self = shift;
424         my $IND = $self->{-parent}->{-IND};
425         my $name = $self->{-base};
426         my $title = $self->{-title};
427
428         print $IND Tr(td(a({-href=>$name.'/index.html'},$name)),
429                         td(a({-href=>$name.'/index.html'},$title))),"\n";
430 }
431
432 sub endsublist {
433         my $self = shift;
434         my $IND = $self->{-IND};
435
436         print $IND end_table,"\n",br({-clear=>'all'}),hr,"\n\n";
437 }
438
439 sub startimglist {
440         my $self = shift;
441         my $IND = $self->{-IND};
442         my $first = $self->{-firstimg}->{-base};
443         my $slideref = sprintf(".html/%s-slide.html",$first);
444
445         print $IND h2("Images"),
446                 a({-href=>$slideref},'Slideshow');
447                 "\n";
448 }
449
450 sub img_entry {
451         my $self = shift;
452         my $IND = $self->{-parent}->{-IND};
453         my $name = $self->{-base};
454         my $title = $self->{-info}->{'Comment'};
455         $title = $name unless ($title);
456         my $thumb = $self->{$sizes[0]};
457         my $medium = $self->{$sizes[1]};
458         my $info = $self->{-info};
459         my ($w, $h) = dim($info);
460
461         #print &infobox($info,$base,$fn),"\n";
462         print $IND table({-class=>'slide'},Tr(td(
463                 a({-href=>".html/$name-info.html",
464                         -onClick=>"return showIbox('$name');"},$title),
465                 br,
466                 a({-href=>$medium,-rel=>"lightbox",-title=>$title},
467                         img({-src=>$thumb})),
468                 br,
469                 a({-href=>$name},"($w x $h)"),
470                 br))),"\n";
471 }
472
473 sub endimglist {
474         my $self = shift;
475         my $IND = $self->{-IND};
476
477         print $IND br({-clear=>'all'}),hr,"\n\n";
478 }
479
480 ######################################################################
481 =cut
482 ######################################################################
483
484 &processdir(getcwd);
485
486 sub processdir {
487         my ($start,$dir)=@_;
488         my $dn=$start;
489         $dn .= "/".$dir if ($dir);
490         unless ( -d $dn ) {
491                 warn "not a directory: $dn";
492                 return;
493         }
494         my $D;
495         unless (opendir($D,$dn)) {
496                 warn "cannot opendir $dn: $!";
497                 return;
498         }
499
500 # recurse into subdirectories BEFORE opening index file
501
502         &iteratedir($D,$start,$dir,sub {
503                 my ($start,$dir,$base)=@_;
504                 my $ndir = $dir;
505                 $ndir .= "/" if ($ndir);
506                 $ndir .= $base;
507                 return unless ( -d $start."/".$ndir );
508                 &processdir($start,$ndir);
509         });
510
511 # fill in title
512
513         my $title=&gettitle($dn,$dir);
514
515 # get include prefix
516
517         my $inc=&getinclude($dn);
518
519 # generate directory index unless suppressed
520
521         if ( -e $dn."/.noindex" ) {
522                 open(STDOUT,">/dev/null");
523         } else {
524                 open(STDOUT,">".$dn."/index.html");
525         }
526
527 # write HTML header
528
529                         -style=>{-src=>[$inc."gallery.css",
530                                         $inc."lightbox.css"]},
531                         -script=>[{-code=>"var incPrefix='$inc';"},
532                                 {-src=>$inc."gallery.js"},
533                                 {-src=>$inc."lightbox.js"}]),"\n";
534         print a({-href=>"../index.html"},"UP");
535         print start_center,"\n";
536         print h1($title),"\n";
537
538 # create list of sub-albums
539
540         my $hassubdirs=0;
541         &iteratedir($D,$start,$dir,sub {
542                 my ($start,$dir,$base)=@_;
543                 my $en=sprintf("%s/%s/%s",$start,$dir,$base);
544                 return unless ( -d $en );
545                 unless ($hassubdirs) {
546                         print hr,h2("Albums"),start_table,"\n";
547                         $hassubdirs=1;
548                 }
549                 &subalbum($base,&gettitle($en,$dir."/".$base));
550         });
551         print end_table,hr,"\n" if ($hassubdirs);
552
553 # create picture gallery
554
555         my @piclist=();
556         my @infolist=();
557
558         my $haspics=0;
559         &iteratedir($D,$start,$dir,sub {
560                 my ($start,$dir,$base)=@_;
561                 my $en=sprintf("%s/%s/%s",$start,$dir,$base);
562                 return unless ( -f $en );
563                 my $info = image_info($en);
564                 if (my $error = $info->{error}) {
565                         if (($error !~ "Unrecognized file format") &&
566                             ($error !~ "Can't read head")) {
567                                 print STDERR "File \"$en\": $error\n";
568                         }
569                         return;
570                 }
571                 if (&processfile($start,$dir,$base,$en,$info)) {
572                         $haspics=1;
573                         push(@piclist,$base);
574                         push(@infolist,$info);
575                 }
576         });
577
578 # write HTML footer
579
580         print br({-clear=>"all"}),"\n";
581         print a({-href=>".html/".$piclist[0]."-slide.html"},"Slideshow");
582         print hr,"\n" if ($haspics);
583         print end_center,"\n";
584         print end_html,"\n";
585
586         close(STDOUT);
587         closedir($D);
588
589 # generate html files for slideshow from @piclist
590
591         for (my $i=0;$i<=$#piclist;$i++) {
592                 my $base=$piclist[$i];
593                 my $pbase;
594                 my $nbase;
595                 $pbase=$piclist[$i-1] if ($i>0);
596                 $nbase=$piclist[$i+1] if ($i<$#piclist);
597                 for my $refresh('static','slide') {
598                         &mkauxfile($start,$dir,$pbase,$base,$nbase,
599                                         $refresh,$infolist[$i]);
600                 }
601         }
602
603 }
604
605 #############################################################
606 # helper functions
607 #############################################################
608
609 sub iteratedir {
610         my ($D,$start,$dir,$prog)=@_;
611         my @list=();
612         while (my $de=readdir($D)) {
613                 next if ($de =~ /^\./);
614                 push(@list,$de);
615         }
616         foreach my $de(sort @list) {
617                 &$prog($start,$dir,$de);
618         }
619         rewinddir($D);
620 }
621
622 sub getinclude {
623         my ($dn)=@_;
624
625         my $depth=20;
626         my $str="";
627         #print STDERR "start include ",$dn."/".$str.".include","\n";
628         while ( ! -d $dn."/".$str.".include" ) {
629                 #print STDERR "not include ",$dn."/".$str.".include","\n";
630                 $str.="../";
631                 last unless ($depth--);
632         }
633         #print STDERR "end include ",$dn."/".$str.".include","\n";
634         if ( -d $dn."/".$str.".include" ) {
635                 #print STDERR "return include ".$str.".include/".$fn,"\n";
636                 return $str.".include/";
637         } else {
638                 return ""; # won't work anyway but return something
639         }
640 }
641
642 sub gettitle {
643         my ($dir,$dflt)=@_;
644
645         my $F;
646         my $str;
647         if (open($F,"<".$dir."/.title")) {
648                 $str=<$F>;
649                 chop $str;
650                 close($F);
651         } else {
652                 print STDERR "enter title for $dir\n";
653                 $str=<>;
654                 if ($str =~ /^\s*$/) {
655                         $str=$dflt;
656                 }
657                 if (open($F,">".$dir."/.title")) {
658                         print $F $str,"\n";
659                         close($F);
660                 } else {
661                         print STDERR "cant open .title in $dir for writing: $!";
662                 }
663         }
664         return $str;
665 }
666
667 sub subalbum {
668         my ($base,$title)=@_;
669
670         print Tr({-bgcolor=>"#c0c0c0"},
671                 td(a({-href=>$base."/index.html"},$base)),
672                 td(a({-href=>$base."/index.html"},$title))),"\n";
673 }
674
675 sub processfile {
676         my ($start,$dir,$base,$fn,$info)=@_;
677
678         my ($w,$h) = dim($info);
679         my $title=$info->{'Comment'};
680         $title=$base unless ($title);
681         my $thumb=&scale($start,$dir,$base,$fn,160,$info);
682         my $medium=&scale($start,$dir,$base,$fn,640,$info);
683         print &infobox($info,$base,$fn),"\n";
684         print table({-class=>'slide'},Tr(td(
685                 a({-href=>".html/$base-info.html",
686                         -onClick=>"return showIbox('$base');"},$title),
687                 br,
688                 a({-href=>$medium,-rel=>"lightbox",-title=>$title},
689                         img({-src=>$thumb})),
690                 br,
691                 a({-href=>$base},"($w x $h)"),
692                 br))),"\n";
693         return 1;
694 }
695
696 sub infobox {
697         my ($info,$base,$fn)=@_;
698
699         my @infokeys=(
700                 'DateTime',
701                 'ExposureTime',
702                 'FNumber',
703                 'Flash',
704                 'ISOSpeedRatings',
705                 'MeteringMode',
706                 'ExposureProgram',
707                 'FocalLength',
708                 'FileSource',
709                 'Make',
710                 'Model',
711                 'Software',
712         );
713
714         my $msg=start_div({-class=>'ibox',-id=>$base,-OnClick=>"HideIbox('$base');"});
715         $msg.=span({-style=>'float: left;'},"Info for $base").
716                 span({-style=>'float: right;'},
717                         a({-href=>"#",-OnClick=>"HideIbox('$base');"},"Close"));
718         $msg.=br({-clear=>'all'});
719         $msg.=start_table;
720         foreach my $k(@infokeys) {
721                 $msg.=Tr(td($k.":"),td($info->{$k}));
722         }
723         $msg.=end_table;
724         $msg.=end_div;
725         return $msg;
726 }
727
728 sub mkauxfile {
729         my ($start,$dir,$pbase,$base,$nbase,$refresh,$info) =@_;
730         my $en=sprintf("%s/%s/.html/%s-%s.html",$start,$dir,$base,$refresh);
731         my $pref;
732         my $nref;
733         if ($pbase) {
734                 $pref=sprintf("%s-%s.html",$pbase,$refresh);
735         } else {
736                 $pref="../index.html";
737         }
738         if ($nbase) {
739                 $nref=sprintf("%s-%s.html",$nbase,$refresh);
740         } else {
741                 $nref="../index.html";
742         }
743         my $toggle;
744         my $toggleref;
745         if ($refresh eq 'slide') {
746                 $toggle='Stop!';
747                 $toggleref=sprintf("%s-static.html",$base);
748         } else {
749                 $toggle='Play-&gt;';
750                 $toggleref=sprintf("%s-slide.html",$base);
751         }
752
753         my $tdir=sprintf "%s/%s/.html",$start,$dir;
754         mkdir($tdir,0755) unless ( -d $tdir );
755
756         unless (open(STDOUT,">".$en)) {
757                 warn "cannot open $en: $!";
758                 return;
759         }
760         my $title=$info->{'Comment'};
761         $title=$base unless ($title);
762         if ($refresh eq 'slide') {
763                 print start_html(-title=>$title,
764                                 -bgcolor=>"#808080",
765                         -head=>meta({-http_equiv=>'Refresh',
766                                 -content=>"3; url=$nref"})),"\n";
767         } else {
768                 print start_html(-title=>$title,
769                                 -bgcolor=>"#808080"),"\n";
770         }
771         print start_center,"\n";
772         print h1($title);
773         print a({-href=>"../index.html"},"Index")," | ";
774         print a({-href=>$pref},"&lt;&lt;Prev")," | ";
775         print a({-href=>$toggleref},$toggle)," | ";
776         print a({-href=>$nref},"Next&gt;&gt;");
777         print p;
778         print img({-src=>"../.640/".$base}),"\n";
779         print end_center,"\n";
780         print end_html,"\n";
781         close(STDOUT);
782 }
783
784 sub scale {
785         my ($start,$dir,$base,$fn,$tsize,$info)=@_;
786         my ($w,$h) = dim($info);
787         my $max=($w>$h)?$w:$h;
788         my $factor=$tsize/$max;
789
790         return $base if ($factor >= 1);
791
792         my $tdir=sprintf "%s/%s/.%s",$start,$dir,$tsize;
793         mkdir($tdir,0755) unless ( -d $tdir );
794         my $tbase=sprintf ".%s/%s",$tsize,$base;
795         my $tfn=sprintf "%s/%s",$tdir,$base;
796         my @sstat=stat($fn);
797         my @tstat=stat($tfn);
798         return $tbase if (@tstat && ($sstat[9] < $tstat[9])); # [9] -> mtime
799
800         print STDERR "scale by $factor from $fn to $tfn\n";
801         &doscaling($fn,$tfn,$factor,$w,$h);
802         return $tbase;
803 }
804
805 sub doscaling {
806         my ($src,$dest,$factor,$w,$h)=@_;
807
808         my $im=new Image::Magick;
809         my $err;
810         #print STDERR "doscale $src -> $dest by $factor\n";
811         $err=$im->Read($src);
812         unless ($err) {
813                 $im->Scale(width=>$w*$factor,height=>$h*$factor);
814                 $err=$im->Write($dest);
815                 warn "ImageMagic: write \"$dest\": $err" if ($err);
816         } else {
817                 warn "ImageMagic: read \"$src\": $err";
818                 system("djpeg \"$src\" | pnmscale \"$factor\" | cjpeg >\"$dest\"");
819         }
820         undef $im;
821 }