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
 133 # 1. first of all, fill title for this directory and create hidden subdirs
 134
 135         $self->initdir;
 136
 137 # 2. iterate through subdirectories to get their titles filled
 138 #    before we start writing out subalbum list
 139
 140         foreach my $dir(@dirlist) {
 141                 print "Dir: $dir->{-fullpath}\n" if ($debug);
 142                 $dir->iterate;
 143         }
 144
 145 # 3. start building index.html for the directory
 146 # 4. iterate through subdirectories to build subalbums list
 147 # 5. iterate through images to build cross-links
 148
 149         foreach my $img(@imglist) {
 150                 print "Img: $img->{-fullpath}\n" if ($debug);
 151         }
 152
 153 # 6. iterate through images to build thumb list and aux html files
 154 # 7. comlplete building index.html for the directory
 155
 156 }
 157
 158 sub isdir {
 159         my $self = shift;
 160         return ( -d $self->{-fullpath} );
 161 }
 162
 163 sub isimg {
 164         my $self = shift;
 165         my $fullpath = $self->{-fullpath};
 166         return 0 unless ( -f $fullpath );
 167         my $info = image_info($fullpath);
 168         if (my $error = $info->{error}) {
 169                 if (($error !~ "Unrecognized file format") &&
 170                     ($error !~ "Can't read head")) {
 171                         warn "File \"$fullpath\": $error\n";
 172                 }
 173                 return 0;
 174         }
 175         $self->{-isimg} = 1;
 176         $self->{-info} = $info;
 177         return 1;
 178 }
 179
 180 sub initdir {
 181         my $self = shift;
 182         my $fullpath = $self->{-fullpath};
 183         for my $subdir(@sizes, 'html') {
 184                 my $tdir=sprintf "%s/.%s",$self->{-fullpath},$subdir;
 185                 mkdir($tdir,0755) unless ( -d $tdir );
 186         }
 187         $self->edittitle;
 188 }
 189
 190 sub edittitle {
 191         my $self = shift;
 192         my $fullpath = $self->{-fullpath};
 193         my $title;
 194         my $T;
 195         if (open($T,'<'.$fullpath.'/.title')) {
 196                 $title = <$T>;
 197                 $title =~ s/[\r\n]*$//;
 198                 close($T);
 199         }
 200         if ($asktitle || (!$title && !$noasktitle)) {
 201                 my $prompt = $self->{-base};
 202                 $prompt = '/' unless ($prompt);
 203                 my $OUT = $term->OUT || \*STDOUT;
 204                 print $OUT "Enter title for $fullpath\n";
 205                 $title = $term->readline($prompt.' >',$title);
 206                 $term->addhistory($title) if ($title);
 207                 if (open($T,'>'.$fullpath.'/.title')) {
 208                         print $T $title,"\n";
 209                         close($T);
 210                 }
 211         }
 212         unless ($title) {
 213                 $title=substr($fullpath,length($self->{-root}))
 214         }
 215         $self->{-title}=$title;
 216         print "title in $fullpath is $title\n" if ($debug);
 217 }
 218
 219 ######################################################################
 220 =cut
 221 ######################################################################
 222
 223 &processdir(getcwd);
 224
 225 sub processdir {
 226         my ($start,$dir)=@_;
 227         my $dn=$start;
 228         $dn .= "/".$dir if ($dir);
 229         unless ( -d $dn ) {
 230                 warn "not a directory: $dn";
 231                 return;
 232         }
 233         my $D;
 234         unless (opendir($D,$dn)) {
 235                 warn "cannot opendir $dn: $!";
 236                 return;
 237         }
 238
 239 # recurse into subdirectories BEFORE opening index file
 240
 241         &iteratedir($D,$start,$dir,sub {
 242                 my ($start,$dir,$base)=@_;
 243                 my $ndir = $dir;
 244                 $ndir .= "/" if ($ndir);
 245                 $ndir .= $base;
 246                 return unless ( -d $start."/".$ndir );
 247                 &processdir($start,$ndir);
 248         });
 249
 250 # fill in title
 251
 252         my $title=&gettitle($dn,$dir);
 253
 254 # get include prefix
 255
 256         my $inc=&getinclude($dn);
 257
 258 # generate directory index unless suppressed
 259
 260         if ( -e $dn."/.noindex" ) {
 261                 open(STDOUT,">/dev/null");
 262         } else {
 263                 open(STDOUT,">".$dn."/index.html");
 264         }
 265
 266 # write HTML header
 267
 268         print start_html(-title => $title,
 269                         -style=>{-src=>[$inc."gallery.css",
 270                                         $inc."lightbox.css"]},
 271                         -script=>[{-code=>"var incPrefix='$inc';"},
 272                                 {-src=>$inc."gallery.js"},
 273                                 {-src=>$inc."lightbox.js"}]),"\n";
 274         print a({-href=>"../index.html"},"UP");
 275         print start_center,"\n";
 276         print h1($title),"\n";
 277
 278 # create list of sub-albums
 279
 280         my $hassubdirs=0;
 281         &iteratedir($D,$start,$dir,sub {
 282                 my ($start,$dir,$base)=@_;
 283                 my $en=sprintf("%s/%s/%s",$start,$dir,$base);
 284                 return unless ( -d $en );
 285                 unless ($hassubdirs) {
 286                         print hr,h2("Albums"),start_table,"\n";
 287                         $hassubdirs=1;
 288                 }
 289                 &subalbum($base,&gettitle($en,$dir."/".$base));
 290         });
 291         print end_table,hr,"\n" if ($hassubdirs);
 292
 293 # create picture gallery
 294
 295         my @piclist=();
 296         my @infolist=();
 297
 298         my $haspics=0;
 299         &iteratedir($D,$start,$dir,sub {
 300                 my ($start,$dir,$base)=@_;
 301                 my $en=sprintf("%s/%s/%s",$start,$dir,$base);
 302                 return unless ( -f $en );
 303                 my $info = image_info($en);
 304                 if (my $error = $info->{error}) {
 305                         if (($error !~ "Unrecognized file format") &&
 306                             ($error !~ "Can't read head")) {
 307                                 print STDERR "File \"$en\": $error\n";
 308                         }
 309                         return;
 310                 }
 311                 if (&processfile($start,$dir,$base,$en,$info)) {
 312                         $haspics=1;
 313                         push(@piclist,$base);
 314                         push(@infolist,$info);
 315                 }
 316         });
 317
 318 # write HTML footer
 319
 320         print br({-clear=>"all"}),"\n";
 321         print a({-href=>".html/".$piclist[0]."-slide.html"},"Slideshow");
 322         print hr,"\n" if ($haspics);
 323         print end_center,"\n";
 324         print end_html,"\n";
 325
 326         close(STDOUT);
 327         closedir($D);
 328
 329 # generate html files for slideshow from @piclist
 330
 331         for (my $i=0;$i<=$#piclist;$i++) {
 332                 my $base=$piclist[$i];
 333                 my $pbase;
 334                 my $nbase;
 335                 $pbase=$piclist[$i-1] if ($i>0);
 336                 $nbase=$piclist[$i+1] if ($i<$#piclist);
 337                 for my $refresh('static','slide') {
 338                         &mkauxfile($start,$dir,$pbase,$base,$nbase,
 339                                         $refresh,$infolist[$i]);
 340                 }
 341         }
 342
 343 }
 344
 345 #############################################################
 346 # helper functions
 347 #############################################################
 348
 349 sub iteratedir {
 350         my ($D,$start,$dir,$prog)=@_;
 351         my @list=();
 352         while (my $de=readdir($D)) {
 353                 next if ($de =~ /^\./);
 354                 push(@list,$de);
 355         }
 356         foreach my $de(sort @list) {
 357                 &$prog($start,$dir,$de);
 358         }
 359         rewinddir($D);
 360 }
 361
 362 sub getinclude {
 363         my ($dn)=@_;
 364
 365         my $depth=20;
 366         my $str="";
 367         #print STDERR "start include ",$dn."/".$str.".include","\n";
 368         while ( ! -d $dn."/".$str.".include" ) {
 369                 #print STDERR "not include ",$dn."/".$str.".include","\n";
 370                 $str.="../";
 371                 last unless ($depth--);
 372         }
 373         #print STDERR "end include ",$dn."/".$str.".include","\n";
 374         if ( -d $dn."/".$str.".include" ) {
 375                 #print STDERR "return include ".$str.".include/".$fn,"\n";
 376                 return $str.".include/";
 377         } else {
 378                 return ""; # won't work anyway but return something
 379         }
 380 }
 381
 382 sub gettitle {
 383         my ($dir,$dflt)=@_;
 384
 385         my $F;
 386         my $str;
 387         if (open($F,"<".$dir."/.title")) {
 388                 $str=<$F>;
 389                 chop $str;
 390                 close($F);
 391         } else {
 392                 print STDERR "enter title for $dir\n";
 393                 $str=<>;
 394                 if ($str =~ /^\s*$/) {
 395                         $str=$dflt;
 396                 }
 397                 if (open($F,">".$dir."/.title")) {
 398                         print $F $str,"\n";
 399                         close($F);
 400                 } else {
 401                         print STDERR "cant open .title in $dir for writing: $!";
 402                 }
 403         }
 404         return $str;
 405 }
 406
 407 sub subalbum {
 408         my ($base,$title)=@_;
 409
 410         print Tr({-bgcolor=>"#c0c0c0"},
 411                 td(a({-href=>$base."/index.html"},$base)),
 412                 td(a({-href=>$base."/index.html"},$title))),"\n";
 413 }
 414
 415 sub processfile {
 416         my ($start,$dir,$base,$fn,$info)=@_;
 417
 418         my ($w,$h) = dim($info);
 419         my $title=$info->{'Comment'};
 420         $title=$base unless ($title);
 421         my $thumb=&scale($start,$dir,$base,$fn,160,$info);
 422         my $medium=&scale($start,$dir,$base,$fn,640,$info);
 423         print &infobox($info,$base,$fn),"\n";
 424         print table({-class=>'slide'},Tr(td(
 425                 a({-href=>".html/$base-info.html",
 426                         -onClick=>"return showIbox('$base');"},$title),
 427                 br,
 428                 a({-href=>$medium,-rel=>"lightbox",-title=>$title},
 429                         img({-src=>$thumb})),
 430                 br,
 431                 a({-href=>$base},"($w x $h)"),
 432                 br))),"\n";
 433         return 1;
 434 }
 435
 436 sub infobox {
 437         my ($info,$base,$fn)=@_;
 438
 439         my @infokeys=(
 440                 'DateTime',
 441                 'ExposureTime',
 442                 'FNumber',
 443                 'Flash',
 444                 'ISOSpeedRatings',
 445                 'MeteringMode',
 446                 'ExposureProgram',
 447                 'FocalLength',
 448                 'FileSource',
 449                 'Make',
 450                 'Model',
 451                 'Software',
 452         );
 453
 454         my $msg=start_div({-class=>'ibox',-id=>$base,-OnClick=>"HideIbox('$base');"});
 455         $msg.=span({-style=>'float: left;'},"Info for $base").
 456                 span({-style=>'float: right;'},
 457                         a({-href=>"#",-OnClick=>"HideIbox('$base');"},"Close"));
 458         $msg.=br({-clear=>'all'});
 459         $msg.=start_table;
 460         foreach my $k(@infokeys) {
 461                 $msg.=Tr(td($k.":"),td($info->{$k}));
 462         }
 463         $msg.=end_table;
 464         $msg.=end_div;
 465         return $msg;
 466 }
 467
 468 sub mkauxfile {
 469         my ($start,$dir,$pbase,$base,$nbase,$refresh,$info) =@_;
 470         my $en=sprintf("%s/%s/.html/%s-%s.html",$start,$dir,$base,$refresh);
 471         my $pref;
 472         my $nref;
 473         if ($pbase) {
 474                 $pref=sprintf("%s-%s.html",$pbase,$refresh);
 475         } else {
 476                 $pref="../index.html";
 477         }
 478         if ($nbase) {
 479                 $nref=sprintf("%s-%s.html",$nbase,$refresh);
 480         } else {
 481                 $nref="../index.html";
 482         }
 483         my $toggle;
 484         my $toggleref;
 485         if ($refresh eq 'slide') {
 486                 $toggle='Stop!';
 487                 $toggleref=sprintf("%s-static.html",$base);
 488         } else {
 489                 $toggle='Play-&gt;';
 490                 $toggleref=sprintf("%s-slide.html",$base);
 491         }
 492
 493         my $tdir=sprintf "%s/%s/.html",$start,$dir;
 494         mkdir($tdir,0755) unless ( -d $tdir );
 495
 496         unless (open(STDOUT,">".$en)) {
 497                 warn "cannot open $en: $!";
 498                 return;
 499         }
 500         my $title=$info->{'Comment'};
 501         $title=$base unless ($title);
 502         if ($refresh eq 'slide') {
 503                 print start_html(-title=>$title,
 504                                 -bgcolor=>"#808080",
 505                         -head=>meta({-http_equiv=>'Refresh',
 506                                 -content=>"3; url=$nref"})),"\n";
 507         } else {
 508                 print start_html(-title=>$title,
 509                                 -bgcolor=>"#808080"),"\n";
 510         }
 511         print start_center,"\n";
 512         print h1($title);
 513         print a({-href=>"../index.html"},"Index")," | ";
 514         print a({-href=>$pref},"&lt;&lt;Prev")," | ";
 515         print a({-href=>$toggleref},$toggle)," | ";
 516         print a({-href=>$nref},"Next&gt;&gt;");
 517         print p;
 518         print img({-src=>"../.640/".$base}),"\n";
 519         print end_center,"\n";
 520         print end_html,"\n";
 521         close(STDOUT);
 522 }
 523
 524 sub scale {
 525         my ($start,$dir,$base,$fn,$tsize,$info)=@_;
 526         my ($w,$h) = dim($info);
 527         my $max=($w>$h)?$w:$h;
 528         my $factor=$tsize/$max;
 529
 530         return $base if ($factor >= 1);
 531
 532         my $tdir=sprintf "%s/%s/.%s",$start,$dir,$tsize;
 533         mkdir($tdir,0755) unless ( -d $tdir );
 534         my $tbase=sprintf ".%s/%s",$tsize,$base;
 535         my $tfn=sprintf "%s/%s",$tdir,$base;
 536         my @sstat=stat($fn);
 537         my @tstat=stat($tfn);
 538         return $tbase if (@tstat && ($sstat[9] < $tstat[9])); # [9] -> mtime
 539
 540         print STDERR "scale by $factor from $fn to $tfn\n";
 541         &doscaling($fn,$tfn,$factor,$w,$h);
 542         return $tbase;
 543 }
 544
 545 sub doscaling {
 546         my ($src,$dest,$factor,$w,$h)=@_;
 547
 548         my $im=new Image::Magick;
 549         my $err;
 550         #print STDERR "doscale $src -> $dest by $factor\n";
 551         $err=$im->Read($src);
 552         unless ($err) {
 553                 $im->Scale(width=>$w*$factor,height=>$h*$factor);
 554                 $err=$im->Write($dest);
 555                 warn "ImageMagic: write \"$dest\": $err" if ($err);
 556         } else {
 557                 warn "ImageMagic: read \"$src\": $err";
 558                 system("djpeg \"$src\" | pnmscale \"$factor\" | cjpeg >\"$dest\"");
 559         }
 560         undef $im;
 561 }