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 use strict;
  28 use Carp;
  29 use POSIX qw/getcwd/;
  30 use CGI qw/:html *table *center *div/;
  31 use Image::Info qw/image_info dim/;
  32 use Image::Magick;
  33
  34 my $ask=1;
  35 my $startdir=getcwd;
  36
  37 ######################################################################
  38
  39 &processdir($startdir);
  40
  41 sub processdir {
  42         my ($start,$dir)=@_;
  43         my $dn=$start;
  44         $dn .= "/".$dir if ($dir);
  45         unless ( -d $dn ) {
  46                 warn "not a directory: $dn";
  47                 return;
  48         }
  49         my $D;
  50         unless (opendir($D,$dn)) {
  51                 warn "cannot opendir $dn: $!";
  52                 return;
  53         }
  54
  55 # recurse into subdirectories BEFORE opening index file
  56
  57         &iteratedir($D,$start,$dir,sub {
  58                 my ($start,$dir,$base)=@_;
  59                 my $ndir = $dir;
  60                 $ndir .= "/" if ($ndir);
  61                 $ndir .= $base;
  62                 return unless ( -d $start."/".$ndir );
  63                 &processdir($start,$ndir);
  64         });
  65
  66 # fill in title
  67
  68         my $title=&gettitle($dn,$dir);
  69
  70 # get include prefix
  71
  72         my $inc=&getinclude($dn);
  73
  74 # generate directory index unless suppressed
  75
  76         if ( -e $dn."/.noindex" ) {
  77                 open(STDOUT,">/dev/null");
  78         } else {
  79                 open(STDOUT,">".$dn."/index.html");
  80         }
  81
  82 # write HTML header
  83
  84         print start_html(-title => $title,
  85                         -style=>{-src=>[$inc."gallery.css",
  86                                         $inc."lightbox.css"]},
  87                         -script=>[{-code=>"var incPrefix='$inc';"},
  88                                 {-src=>$inc."gallery.js"},
  89                                 {-src=>$inc."lightbox.js"}]),"\n";
  90         print a({-href=>"../index.html"},"UP");
  91         print start_center,"\n";
  92         print h1($title),"\n";
  93
  94 # create list of sub-albums
  95
  96         my $hassubdirs=0;
  97         &iteratedir($D,$start,$dir,sub {
  98                 my ($start,$dir,$base)=@_;
  99                 my $en=sprintf("%s/%s/%s",$start,$dir,$base);
 100                 return unless ( -d $en );
 101                 unless ($hassubdirs) {
 102                         print hr,h2("Albums"),start_table,"\n";
 103                         $hassubdirs=1;
 104                 }
 105                 &subalbum($base,&gettitle($en,$dir."/".$base));
 106         });
 107         print end_table,hr,"\n" if ($hassubdirs);
 108
 109 # create picture gallery
 110
 111         my @piclist=();
 112         my @infolist=();
 113
 114         my $haspics=0;
 115         &iteratedir($D,$start,$dir,sub {
 116                 my ($start,$dir,$base)=@_;
 117                 my $en=sprintf("%s/%s/%s",$start,$dir,$base);
 118                 return unless ( -f $en );
 119                 my $info = image_info($en);
 120                 if (my $error = $info->{error}) {
 121                         if (($error !~ "Unrecognized file format") &&
 122                             ($error !~ "Can't read head")) {
 123                                 print STDERR "File \"$en\": $error\n";
 124                         }
 125                         return;
 126                 }
 127                 if (&processfile($start,$dir,$base,$en,$info)) {
 128                         $haspics=1;
 129                         push(@piclist,$base);
 130                         push(@infolist,$info);
 131                 }
 132         });
 133
 134 # write HTML footer
 135
 136         print br({-clear=>"all"}),"\n";
 137         print a({-href=>".html/".$piclist[0]."-slide.html"},"Slideshow");
 138         print hr,"\n" if ($haspics);
 139         print end_center,"\n";
 140         print end_html,"\n";
 141
 142         close(STDOUT);
 143         closedir($D);
 144
 145 # generate html files for slideshow from @piclist
 146
 147         for (my $i=0;$i<=$#piclist;$i++) {
 148                 my $base=$piclist[$i];
 149                 my $pbase;
 150                 my $nbase;
 151                 $pbase=$piclist[$i-1] if ($i>0);
 152                 $nbase=$piclist[$i+1] if ($i<$#piclist);
 153                 for my $refresh('static','slide') {
 154                         &mkauxfile($start,$dir,$pbase,$base,$nbase,
 155                                         $refresh,$infolist[$i]);
 156                 }
 157         }
 158
 159 }
 160
 161 #############################################################
 162 # helper functions
 163 #############################################################
 164
 165 sub iteratedir {
 166         my ($D,$start,$dir,$prog)=@_;
 167         my @list=();
 168         while (my $de=readdir($D)) {
 169                 next if ($de =~ /^\./);
 170                 push(@list,$de);
 171         }
 172         foreach my $de(sort @list) {
 173                 &$prog($start,$dir,$de);
 174         }
 175         rewinddir($D);
 176 }
 177
 178 sub getinclude {
 179         my ($dn)=@_;
 180
 181         my $depth=20;
 182         my $str="";
 183         #print STDERR "start include ",$dn."/".$str.".include","\n";
 184         while ( ! -d $dn."/".$str.".include" ) {
 185                 #print STDERR "not include ",$dn."/".$str.".include","\n";
 186                 $str.="../";
 187                 last unless ($depth--);
 188         }
 189         #print STDERR "end include ",$dn."/".$str.".include","\n";
 190         if ( -d $dn."/".$str.".include" ) {
 191                 #print STDERR "return include ".$str.".include/".$fn,"\n";
 192                 return $str.".include/";
 193         } else {
 194                 return ""; # won't work anyway but return something
 195         }
 196 }
 197
 198 sub gettitle {
 199         my ($dir,$dflt)=@_;
 200
 201         my $F;
 202         my $str;
 203         if (open($F,"<".$dir."/.title")) {
 204                 $str=<$F>;
 205                 chop $str;
 206                 close($F);
 207         } else {
 208                 print STDERR "enter title for $dir\n";
 209                 $str=<>;
 210                 if ($str =~ /^\s*$/) {
 211                         $str=$dflt;
 212                 }
 213                 if (open($F,">".$dir."/.title")) {
 214                         print $F $str,"\n";
 215                         close($F);
 216                 } else {
 217                         print STDERR "cant open .title in $dir for writing: $!";
 218                 }
 219         }
 220         return $str;
 221 }
 222
 223 sub subalbum {
 224         my ($base,$title)=@_;
 225
 226         print Tr({-bgcolor=>"#c0c0c0"},
 227                 td(a({-href=>$base."/index.html"},$base)),
 228                 td(a({-href=>$base."/index.html"},$title))),"\n";
 229 }
 230
 231 sub processfile {
 232         my ($start,$dir,$base,$fn,$info)=@_;
 233
 234         my ($w,$h) = dim($info);
 235         my $title=$info->{'Comment'};
 236         $title=$base unless ($title);
 237         my $thumb=&scale($start,$dir,$base,$fn,160,$info);
 238         my $medium=&scale($start,$dir,$base,$fn,640,$info);
 239         print &infobox($info,$base,$fn),"\n";
 240         print table({-class=>'slide'},Tr(td(
 241                 a({-href=>".html/$base-info.html",
 242                         -onClick=>"return showIbox('$base');"},$title),
 243                 br,
 244                 a({-href=>$medium,-rel=>"lightbox",-title=>$title},
 245                         img({-src=>$thumb})),
 246                 br,
 247                 a({-href=>$base},"($w x $h)"),
 248                 br))),"\n";
 249         return 1;
 250 }
 251
 252 sub infobox {
 253         my ($info,$base,$fn)=@_;
 254
 255         my @infokeys=(
 256                 'DateTime',
 257                 'ExposureTime',
 258                 'FNumber',
 259                 'Flash',
 260                 'ISOSpeedRatings',
 261                 'MeteringMode',
 262                 'ExposureProgram',
 263                 'FocalLength',
 264                 'FileSource',
 265                 'Make',
 266                 'Model',
 267                 'Software',
 268         );
 269
 270         my $msg=start_div({-class=>'ibox',-id=>$base,-OnClick=>"HideIbox('$base');"});
 271         $msg.=span({-style=>'float: left;'},"Info for $base").
 272                 span({-style=>'float: right;'},
 273                         a({-href=>"#",-OnClick=>"HideIbox('$base');"},"Close"));
 274         $msg.=br({-clear=>'all'});
 275         $msg.=start_table;
 276         foreach my $k(@infokeys) {
 277                 $msg.=Tr(td($k.":"),td($info->{$k}));
 278         }
 279         $msg.=end_table;
 280         $msg.=end_div;
 281         return $msg;
 282 }
 283
 284 sub mkauxfile {
 285         my ($start,$dir,$pbase,$base,$nbase,$refresh,$info) =@_;
 286         my $en=sprintf("%s/%s/.html/%s-%s.html",$start,$dir,$base,$refresh);
 287         my $pref;
 288         my $nref;
 289         if ($pbase) {
 290                 $pref=sprintf("%s-%s.html",$pbase,$refresh);
 291         } else {
 292                 $pref="../index.html";
 293         }
 294         if ($nbase) {
 295                 $nref=sprintf("%s-%s.html",$nbase,$refresh);
 296         } else {
 297                 $nref="../index.html";
 298         }
 299         my $toggle;
 300         my $toggleref;
 301         if ($refresh eq 'slide') {
 302                 $toggle='Stop!';
 303                 $toggleref=sprintf("%s-static.html",$base);
 304         } else {
 305                 $toggle='Play-&gt;';
 306                 $toggleref=sprintf("%s-slide.html",$base);
 307         }
 308
 309         my $tdir=sprintf "%s/%s/.html",$start,$dir;
 310         mkdir($tdir,0755) unless ( -d $tdir );
 311
 312         unless (open(STDOUT,">".$en)) {
 313                 warn "cannot open $en: $!";
 314                 return;
 315         }
 316         my $title=$info->{'Comment'};
 317         $title=$base unless ($title);
 318         if ($refresh eq 'slide') {
 319                 print start_html(-title=>$title,
 320                                 -bgcolor=>"#808080",
 321                         -head=>meta({-http_equiv=>'Refresh',
 322                                 -content=>"3; url=$nref"})),"\n";
 323         } else {
 324                 print start_html(-title=>$title,
 325                                 -bgcolor=>"#808080"),"\n";
 326         }
 327         print start_center,"\n";
 328         print h1($title);
 329         print a({-href=>"../index.html"},"Index")," | ";
 330         print a({-href=>$pref},"&lt;&lt;Prev")," | ";
 331         print a({-href=>$toggleref},$toggle)," | ";
 332         print a({-href=>$nref},"Next&gt;&gt;");
 333         print p;
 334         print img({-src=>"../.640/".$base}),"\n";
 335         print end_center,"\n";
 336         print end_html,"\n";
 337         close(STDOUT);
 338 }
 339
 340 sub scale {
 341         my ($start,$dir,$base,$fn,$tsize,$info)=@_;
 342         my ($w,$h) = dim($info);
 343         my $max=($w>$h)?$w:$h;
 344         my $factor=$tsize/$max;
 345
 346         return $base if ($factor >= 1);
 347
 348         my $tdir=sprintf "%s/%s/.%s",$start,$dir,$tsize;
 349         mkdir($tdir,0755) unless ( -d $tdir );
 350         my $tbase=sprintf ".%s/%s",$tsize,$base;
 351         my $tfn=sprintf "%s/%s",$tdir,$base;
 352         my @sstat=stat($fn);
 353         my @tstat=stat($tfn);
 354         return $tbase if (@tstat && ($sstat[9] < $tstat[9])); # [9] -> mtime
 355
 356         print STDERR "scale by $factor from $fn to $tfn\n";
 357         &doscaling($fn,$tfn,$factor,$w,$h);
 358         return $tbase;
 359 }
 360
 361 sub doscaling {
 362         my ($src,$dest,$factor,$w,$h)=@_;
 363
 364         my $im=new Image::Magick;
 365         my $err;
 366         #print STDERR "doscale $src -> $dest by $factor\n";
 367         $err=$im->Read($src);
 368         unless ($err) {
 369                 $im->Scale(width=>$w*$factor,height=>$h*$factor);
 370                 $err=$im->Write($dest);
 371                 warn "ImageMagic: write \"$dest\": $err" if ($err);
 372         } else {
 373                 warn "ImageMagic: read \"$src\": $err";
 374                 system("djpeg \"$src\" | pnmscale \"$factor\" | cjpeg >\"$dest\"");
 375         }
 376         undef $im;
 377 }