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=>"../"},"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 hr,"\n" if ($haspics);
 138         print end_center,"\n";
 139         print end_html,"\n";
 140
 141         close(STDOUT);
 142         closedir($D);
 143
 144 # generate html files for slideshow from @piclist
 145
 146         for (my $i=0;$i<=$#piclist;$i++) {
 147                 my $base=$piclist[$i];
 148                 my $pbase;
 149                 my $nbase;
 150                 $pbase=$piclist[$i-1] if ($i>0);
 151                 $nbase=$piclist[$i+1] if ($i<$#piclist);
 152                 for my $refresh('static','slide') {
 153                         &mkauxfile($start,$dir,$pbase,$base,$nbase,
 154                                         $refresh,$infolist[$i]);
 155                 }
 156         }
 157
 158 }
 159
 160 #############################################################
 161 # helper functions
 162 #############################################################
 163
 164 sub iteratedir {
 165         my ($D,$start,$dir,$prog)=@_;
 166         my @list=();
 167         while (my $de=readdir($D)) {
 168                 next if ($de =~ /^\./);
 169                 push(@list,$de);
 170         }
 171         foreach my $de(sort @list) {
 172                 &$prog($start,$dir,$de);
 173         }
 174         rewinddir($D);
 175 }
 176
 177 sub getinclude {
 178         my ($dn)=@_;
 179
 180         my $depth=20;
 181         my $str="";
 182         #print STDERR "start include ",$dn."/".$str.".include","\n";
 183         while ( ! -d $dn."/".$str.".include" ) {
 184                 #print STDERR "not include ",$dn."/".$str.".include","\n";
 185                 $str.="../";
 186                 last unless ($depth--);
 187         }
 188         #print STDERR "end include ",$dn."/".$str.".include","\n";
 189         if ( -d $dn."/".$str.".include" ) {
 190                 #print STDERR "return include ".$str.".include/".$fn,"\n";
 191                 return $str.".include/";
 192         } else {
 193                 return ""; # won't work anyway but return something
 194         }
 195 }
 196
 197 sub gettitle {
 198         my ($dir,$dflt)=@_;
 199
 200         my $F;
 201         my $str;
 202         if (open($F,"<".$dir."/.title")) {
 203                 $str=<$F>;
 204                 chop $str;
 205                 close($F);
 206         } else {
 207                 print STDERR "enter title for $dir\n";
 208                 $str=<>;
 209                 if ($str =~ /^\s*$/) {
 210                         $str=$dflt;
 211                 }
 212                 if (open($F,">".$dir."/.title")) {
 213                         print $F $str,"\n";
 214                         close($F);
 215                 } else {
 216                         print STDERR "cant open .title in $dir for writing: $!";
 217                 }
 218         }
 219         return $str;
 220 }
 221
 222 sub subalbum {
 223         my ($base,$title)=@_;
 224
 225         print Tr({-bgcolor=>"#c0c0c0"},
 226                 td(a({-href=>$base."/"},$base)),
 227                 td(a({-href=>$base."/"},$title))),"\n";
 228 }
 229
 230 sub processfile {
 231         my ($start,$dir,$base,$fn,$info)=@_;
 232
 233         my ($w,$h) = dim($info);
 234         my $title=$info->{'Comment'};
 235         $title=$base unless ($title);
 236         my $thumb=&scale($start,$dir,$base,$fn,160,$info);
 237         my $medium=&scale($start,$dir,$base,$fn,640,$info);
 238         print &infobox($info,$base,$fn),"\n";
 239         print table({-class=>'slide'},Tr(td(
 240                 a({-href=>".html/$base-info.html",
 241                         -onClick=>"return showIbox('$base');"},$title),
 242                 br,
 243                 a({-href=>$medium,-rel=>"lightbox",-title=>$title},
 244                         img({-src=>$thumb})),
 245                 br,
 246                 a({-href=>$base},"($w x $h)"),
 247                 br))),"\n";
 248         return 1;
 249 }
 250
 251 sub infobox {
 252         my ($info,$base,$fn)=@_;
 253
 254         my @infokeys=(
 255                 'DateTime',
 256                 'ExposureTime',
 257                 'FNumber',
 258                 'Flash',
 259                 'ISOSpeedRatings',
 260                 'MeteringMode',
 261                 'ExposureProgram',
 262                 'FocalLength',
 263                 'FileSource',
 264                 'Make',
 265                 'Model',
 266                 'Software',
 267         );
 268
 269         my $msg=start_div({-class=>'ibox',-id=>$base,-OnClick=>"HideIbox('$base');"});
 270         $msg.=span({-style=>'float: left;'},"Info for $base").
 271                 span({-style=>'float: right;'},
 272                         a({-href=>"#",-OnClick=>"HideIbox('$base');"},"Close"));
 273         $msg.=br({-clear=>'all'});
 274         $msg.=start_table;
 275         foreach my $k(@infokeys) {
 276                 $msg.=Tr(td($k.":"),td($info->{$k}));
 277         }
 278         $msg.=end_table;
 279         $msg.=end_div;
 280         return $msg;
 281 }
 282
 283 sub mkauxfile {
 284         my ($start,$dir,$pbase,$base,$nbase,$refresh,$info) =@_;
 285         my $en=sprintf("%s/%s/.html/%s-%s.html",$start,$dir,$base,$refresh);
 286         my $pref;
 287         my $nref;
 288         if ($pbase) {
 289                 $pref=sprintf("%s-%s.html",$pbase,$refresh);
 290         } else {
 291                 $pref="../";
 292         }
 293         if ($nbase) {
 294                 $nref=sprintf("%s-%s.html",$nbase,$refresh);
 295         } else {
 296                 $nref="../";
 297         }
 298
 299         my $tdir=sprintf "%s/%s/.html",$start,$dir;
 300         mkdir($tdir,0755) unless ( -d $tdir );
 301
 302         unless (open(STDOUT,">".$en)) {
 303                 warn "cannot open $en: $!";
 304                 return;
 305         }
 306         my $title=$info->{'Comment'};
 307         $title=$base unless ($title);
 308         if ($refresh eq 'slide') {
 309                 print start_html(-title=>$title,
 310                         -head=>meta({-http_equiv=>'Refresh',
 311                                 -content=>"3; url=$nref"})),"\n";
 312         } else {
 313                 print start_html(-title=>$title),"\n";
 314         }
 315         print img({-src=>"../.640/".$base});
 316         print end_html,"\n";
 317         close(STDOUT);
 318 }
 319
 320 sub scale {
 321         my ($start,$dir,$base,$fn,$tsize,$info)=@_;
 322         my ($w,$h) = dim($info);
 323         my $max=($w>$h)?$w:$h;
 324         my $factor=$tsize/$max;
 325
 326         return $base if ($factor >= 1);
 327
 328         my $tdir=sprintf "%s/%s/.%s",$start,$dir,$tsize;
 329         mkdir($tdir,0755) unless ( -d $tdir );
 330         my $tbase=sprintf ".%s/%s",$tsize,$base;
 331         my $tfn=sprintf "%s/%s",$tdir,$base;
 332         my @sstat=stat($fn);
 333         my @tstat=stat($tfn);
 334         return $tbase if (@tstat && ($sstat[9] < $tstat[9])); # [9] -> mtime
 335
 336         print STDERR "scale by $factor from $fn to $tfn\n";
 337         &doscaling($fn,$tfn,$factor,$w,$h);
 338         return $tbase;
 339 }
 340
 341 sub doscaling {
 342         my ($src,$dest,$factor,$w,$h)=@_;
 343
 344         my $im=new Image::Magick;
 345         my $err;
 346         #print STDERR "doscale $src -> $dest by $factor\n";
 347         $err=$im->Read($src);
 348         unless ($err) {
 349                 $im->Scale(width=>$w*$factor,height=>$h*$factor);
 350                 $err=$im->Write($dest);
 351                 warn "ImageMagic: write \"$dest\": $err" if ($err);
 352         } else {
 353                 warn "ImageMagic: read \"$src\": $err";
 354                 system("djpeg \"$src\" | pnmscale \"$factor\" | cjpeg >\"$dest\"");
 355         }
 356         undef $im;
 357 }