mkgallery.pl

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