#!/usr/bin/perl

=head1 NAME

quick-photo-index - do very simple thumbnails of image directories

=head1 SYNOPSIS

  # do just the current directory
  quick-photo-index

  # do multiple directories
  quick-photo-index vacation-folders-*

=head1 DESCRIPTION

Takes one or more directories full of images and generates HTML pages
with thumbnails and detailed EXIF information on those images.

The original images are not touched; rather, this script creates an
"index.html" file in each directory with thumbnails of all the images
(which are in turn stored in a "tn" subdirectory).  The thumbnail
images each link to an HTML page with a medium-sized image and a dump
of the EXIF data for that picture; both the HTML and the medium-sized
image are stored in the "med" subdirectory.  The "medium" HTML pages
also have basic navigation links (prev/next/up/full-sized).

Finally, it creates a "makefile" that has a "clean" target, which
removes all these files and subdirectories that it just added.

Sample galleries can be found under

  http://scrye.com/~tkil/photos/

=head1 DEPENDENCIES

=head2 External Programs

=over

=item convert

From the ImageMagick suite.  This is used to do the actual resizing
from original down to thumbnail or medium size.

=item jpegtran

From the libjpeg library.  Does lossless rotation (which I only apply
to the medium and thumbnail images -- again, I don't touch the
originals.)

=back

=head2 Perl Modules

=over

=item Time::HiRes

=item Image::Info

=back

=head1 LICENSE

This script is available under the same terms as Perl itself (either
the Artistic License, or GPLv2).

=head1 AUTHOR

Tkil <tkil@scrye.com>

=cut

use strict;
use warnings;

use Scalar::Util qw(reftype);
use Cwd qw(cwd);
use File::Copy qw(move);
use File::Basename qw( basename );
use POSIX qw(strftime);
use Time::HiRes qw(gettimeofday tv_interval);
use Sys::Hostname qw( hostname );

use lib qw( /home/brand1/tkil/perl5/lib/perl5/5.8.0
            /home/brand1/tkil/perl5/lib/perl5/site_perl/5.8.0 );
use Image::Info qw(image_info);

# prototypes
sub find_in_path ( $ );
sub get_unique ( $ );
sub simplify_image_info ( $ );
sub pretty_file_size ( $ );
sub index_one_dir ( $ );

# constants
my $TN_SIZE  = 256;
my $MED_SIZE = 640;

# used for resizing, is a part of ImageMagick
my $CONVERT_PROG = find_in_path 'convert'
  or die "couldn't find convert!";
my $CONVERT_QUAL = 85;

# used for lossless jpg rotation, is a part of libjpeg
my $JPEGTRAN_PROG = find_in_path 'jpegtran'
  or die "couldn't find jpegtran!";

# change these to whatever you want, otherwise will be determined
# automatically
my $user_full_name  = '';
my $user_email_addr = '';

@ARGV = ( cwd ) unless @ARGV;

{
    my ( $login, $gcos ) = (getpwuid $>)[0,6];
    $gcos =~ s/,.*$//;
    my @chunks = split /\./, hostname;
    if ( @chunks > 2 )
    {
        shift @chunks;
    }

    $user_full_name = $gcos
      unless $user_full_name;
    $user_email_addr = $login . '@' . join '.', @chunks
      unless $user_email_addr;
}

foreach my $dir ( @ARGV )
{
    print STDERR "=== $dir ===\n";
    index_one_dir $dir;
}

exit 0;

# accepts fully-qualified names and tries to make useful unique names.
# works for either files or directories.
sub get_unique ($ )
{
    my $orig = shift;

    # early optimization:
    unless (-e $orig) { return $orig; }

    # now try to get the bits out.
    $orig =~ s|/$||;            # remove trailing slash
    my ($dir, $base) =
      ( $orig =~ m{ ^ (.*?) / ([^/]+) $ }x );
    my ($start, $num, $ext) =
      ( $base =~ m{ ^ (.*?) (?: -(\d+) )? (?: \.(\w+) )? $ }x );
    $num = 0 unless defined $num;
    $ext = '' unless defined $ext;

    # print qq{orig="$orig"\ndir="$dir", base="$base"\nstart="$start", num="$num", ext="$ext"\n};

    my $new = $orig;
    while (-e $new)
    {
        ++$num;
        $new = "$dir/$start-$num";
        if ( length $ext ) { $new .= ".$ext"; }
    }

    return $new;
}

sub get_primary_unique ( $ )
{
    my ( $desired ) = @_;
    my $unique = get_unique $desired;

    if ( $unique ne $desired )
    {
        # need to move existing index file to the new name, and we'll just
        # use index.html regardless.
        print STDERR
          "moving $desired\n",
          "    to $unique\n";
        move $desired, $unique
          or die "error moving $desired to $unique: $!";
    }

    return $desired;
}

sub normalize_file_names ( $ @ )
{
    my ( $dir, @orig ) = @_;

    my @new;

  FILE:
    for my $file ( @orig )
    {
        # make it lowercase
        my $new = lc $file;

        if ( $new =~ m/^..._(\d{4}\.[^.]+)$/ )
        {
            # turn "dcp_1234.jpg" or "b01_1235.jpg" into "1234.jpg" etc
            $new = $1;
        }
        else
        {
            # don't mess with it.
            push @new, $file;
            next FILE;
        }

        # did it actually change?
        if ( $file ne $new && ! -e "$dir/$new" )
        {
            if ( move "$dir/$file", "$dir/$new" )
            {
                print STDERR "  $file -> $new\n";
                $file = $new;
            }
            else
            {
                warn "$0: unable to rename $file to $new: $!";
            }
        }

        # save the name of the file
        push @new, $file;
    }
    return @new;
}

sub gen_nav_bar ( $ @ )
{
    my ( $i, @all_info ) = @_;

    my @nav_bar = ( [ $all_info[0]{med_html},        'First' ],
                    [ $all_info[$i]{prev_med_html},  'Previous' ],
                    [ '../index.html',               'Index' ],
                    [ "../$all_info[$i]{f}",         'Full-Sized'],
                    [ $all_info[$i]{next_med_html},  'Next' ],
                    [ $all_info[-1]{med_html},       'Last' ] );

    return join ' | ', map
    {
        my ( $url, $label ) = @$_;
        $label =~ s/>/&gt;/g;
        $label =~ s/</&lt;/g;
        $url ? qq|<a href="$url">$label</a>|
          : qq|<font color="#888888">$label</font>|;
    } @nav_bar;
}

# largely cribbed in concept from:
# http://sylvana.net/jpegcrop/exif_orientation.html
sub needs_rotate ( $ )
{
    my ( $image_info ) = @_;

    local $_ = $image_info->{Orientation}
      or return;

    # yet another image::info glitch?  maybe.
    if ( my $rt = reftype $_ )
    {
        if ( $rt eq 'ARRAY' )
        {
            $_ = $_->[0];
        }
        else
        {
            warn "unknown orientation type '$rt'";
            return;
        }
    }

    my @args;

    if    ( /top_left/  ) { return }
    elsif ( /top_right/ ) { push @args, qw( -flip horizontal ) }
    elsif ( /bot_right/ ) { push @args, qw( -rotate 180      ) }
    elsif ( /bot_left/  ) { push @args, qw( -flip vertical   ) }
    elsif ( /left_top/  ) { push @args, qw( -transpose       ) }
    elsif ( /right_top/ ) { push @args, qw( -rotate 90       ) }
    elsif ( /right_bot/ ) { push @args, qw( -transverse      ) }
    elsif ( /left_bot/  ) { push @args, qw( -rotate 270      ) }
    else
    {
        warn "unknown orientation '$_'";
        return;
    }

    push @args, qw( -copy all );

    return @args;
}

sub index_one_dir ( $ )
{
    my ( $dir ) = @_;

    opendir D, $dir
      or die "couldn't opendir $dir: $!";
    my @raw_image_files = grep /\.(?:tiff?|png|jpe?g|gif)$/i, readdir D;
    closedir D
      or die "error closing $dir: $!";

    unless ( @raw_image_files )
    {
        warn "found no image files in directory $dir!";
        return;
    }

    my $make_file_fq = "$dir/makefile";
    open MAKEFILE, "> $make_file_fq"
      or die "opening $make_file_fq for write: $!";
    print MAKEFILE "clean:\n\trm -rf med tn index.html makefile\n";
    close MAKEFILE
      or die "closing $make_file_fq after write: $!";

    my $med_dir_fq = get_primary_unique "$dir/med";
    my $tn_dir_fq  = get_primary_unique "$dir/tn";
    my $index_fq   = get_primary_unique "$dir/index.html";

    mkdir $tn_dir_fq, 0755
      or die "couldn't create directory $tn_dir_fq: $!";
    mkdir $med_dir_fq, 0755
      or die "couldn't create directory $med_dir_fq: $!";

    # ----------------------------------------------------------------------
    # normalize names

    my @image_files = normalize_file_names $dir, sort @raw_image_files;

    # ----------------------------------------------------------------------

    open OUT, ">$index_fq"
      or die "couldn't open $index_fq: $!";

    my $ts = do
    {
        my $t = time;
               strftime( "%Y-%m-%d %T %Z", localtime($t) ) .
        ' [' . strftime( "%Y-%m-%d %TZ", gmtime($t)) . ']'
      };

    my $title = basename $dir;

    print OUT <<HTML;
<html>
  <head>
    <title>$title</title>
    <meta name="generator" content="$0">
  </head>
  <body bgcolor="#333333" text="#bbbbbb" link="#4444aa" vlink="#888888">
    <h1>$title</h1>
HTML

    my @all_info;

    # find info for each file individually
    foreach my $i ( 0 .. $#image_files )
    {
        my $f = $image_files[$i];
        my $med = "med-$f";
        my $tn  = "tn-$f";

        my %info = ( f   => $f,   fq     => "$dir/$f",
                     med => $med, med_fq => "$med_dir_fq/$med",
                     tn  => $tn,  tn_fq  => "$tn_dir_fq/$tn" );

        my $med_html = $info{med};
        $med_html =~ s/(\.\w+)?$/.html/;
        $info{med_html} = $med_html;
        $info{med_html_fq} = "$med_dir_fq/$med_html";

        $all_info[$i] = \%info;
    }

    # find info for interdependencies
    foreach my $i ( 0 .. $#image_files )
    {
        if ( $i > 0 )
        {
            $all_info[$i]{prev_med_html} = $all_info[$i-1]{med_html};
        }
        if ( $i < $#image_files )
        {
            $all_info[$i]{next_med_html} = $all_info[$i+1]{med_html};
        }
    }

    my $n_images = @image_files;
    foreach my $i ( 0 .. $#image_files )
    {
        my $info = $all_info[$i];

        my $f = $info->{f};
        my $fq = $info->{fq};

        print STDERR "$fq [", $i+1, "/$n_images: " . pretty_file_size($fq) . "]: ";

        # -------------------------------------------------------------------------

        print STDERR "\n  medium... ";

        my $med_name_fq = $info->{med_fq};

        {
            my $geom = $MED_SIZE . 'x' . $MED_SIZE;
            my @args = ( $CONVERT_PROG, '-size', $geom, $fq,
                         '-quality', $CONVERT_QUAL,
                         '-strip',
                         '-geometry', "$geom>", $med_name_fq );
            my $t0 = [ gettimeofday ];
            my $rc = system @args;
            if ($rc != 0)
            {
                warn "system failed for file \"$f\": $?";
            }
            my $t1 = [ gettimeofday ];
            printf STDERR "(%0.2fs) ", tv_interval($t0, $t1);
        }

        my $med_html_file = $info->{med_html_fq};
        open MED, ">$med_html_file"
          or die "couldn't open medium html file \"$med_html_file\": $!";

        my @rotation_args;

        my $image_info_table = do
        {
            my ($main, $thumb) = image_info $fq;

            @rotation_args = needs_rotate $main;

            my $main_simp = simplify_image_info($main);
            my $thumb_simp = simplify_image_info($thumb);

            my @rows;

            foreach my $set ( [ 'Main Image' => $main_simp ],
                              [ 'Thumbnail' => $thumb_simp ] )
            {
                my ($label, $href) = @$set;
                push @rows, "<tr><th colspan=\"2\">$label</th></tr>";
                foreach my $k (sort keys %$href)
                {
                    my $v = $href->{$k};
                    $v =~ s|\n|<br />|g;
                    push @rows, "<tr><td valign=\"top\">$k</td><td>$v</td></tr>";
                }
            }

            join "\n", ( "<table>", @rows, "</table>" );
        };

        my $nav_bar = gen_nav_bar $i, @all_info;

        print MED <<HTML;
<html>
  <head>
    <title>$f</title>
  </head>
  <body bgcolor="#333333" text="#bbbbbb" link="#4444aa" vlink="#888888">
    $nav_bar<br />
    <img src="med-$f"> <br />
    <h3>Image Info</h3>
$image_info_table
  </body>
</html>
HTML

        close MED
          or die "error closing medium html file \"$med_html_file\": $!";

        my ($med_name_ref) = $med_html_file =~ m|/([^/]+/[^/]+)$|;

        print STDERR "[" . pretty_file_size($med_name_fq) . "] ";

        # -------------------------------------------------------------------------

        print STDERR "\n  thumbnail... ";

        my $tn_name_fq = $info->{tn_fq};

        {
            my $geom = $TN_SIZE . 'x' . $TN_SIZE;
            my @args = ( $CONVERT_PROG, '-size', $geom, $med_name_fq,
                         '-quality', $CONVERT_QUAL,
                         '-strip',
                         '-geometry', "$geom>", $tn_name_fq );
            my $t0 = [ gettimeofday ];
            my $rc = system @args;
            if ($rc != 0)
            {
                warn "system failed for file \"$f\": $?";
            }
            my $t1 = [ gettimeofday ];
            printf STDERR "(%0.2fs) ", tv_interval($t0, $t1);
        }

        my ($tn_name_ref) = $tn_name_fq =~ m|/([^/]+/[^/]+)$|;

        print STDERR "[" . pretty_file_size($tn_name_fq) . "] ";

        # -------------------------------------------------------------------------

        if ( @rotation_args )
        {
            print STDERR "rotating... ";
            foreach my $key ( qw( med_fq tn_fq ) )
            {
                my $file = $info->{$key};
                my $tmp = $file . ".tmp";
                move $file, $tmp;
                my @cmd = ( $JPEGTRAN_PROG, @rotation_args,
                            '-outfile', $file, $tmp );
                # print "trans: @cmd\n";
                system @cmd;
                unlink $tmp;
            }
        }

        print STDERR "done.\n";

        print OUT <<HTML;
      <a href="$med_name_ref"
        ><img src="$tn_name_ref"
              alt="$f"></a>
HTML
    }

    print OUT <<HTML;
    <hr>
    Generated by $user_full_name
    &lt;<a href="mailto:$user_email_addr">$user_email_addr</a>&gt;<br />
    at $ts<br />
    using <a href="http://scrye.com/~tkil/perl/quick-photo-index"
      >quick-photo-index</a>.
  </body>
</html>
HTML

    close OUT
      or die "error closing $index_fq: $!";
}

# given a name of a program, look through $ENV{PATH} to see if we can
# find where it comes from.  returns the fully-qualified path to the
# executable.
{
    my ( @paths, $path_init );

    sub find_in_path ( $ )
    {
        my $prog = shift;

        unless ($path_init)
        {
            @paths = split /:/, $ENV{PATH} || "";
            $path_init = 1;
        }

        foreach my $p (@paths)
        {
            my $candidate = "$p/$prog";
            return $candidate if -x $candidate;
        }

        return;
    }
}

# given a hash reference as an argument, return another hash reference
# with all the EXIF values displayed sanely.
sub simplify_image_info ( $ )
{
    my $info_href = shift;

    my $chars_to_int = sub
    {
        my $s = shift;
        return join " ", unpack "C*", $s;
    };

    my $rational = sub
    {
        my ($rat, $n_dec) = (@_, 0);
        my ($num, $denom) = @{$rat}[0,1];
        my $format = '%.' . $n_dec . 'f';
        return ($denom == 0 ? "NaN" : sprintf $format, $num/$denom );
    };

    my $decode_color_components = sub
    {
        my $aref = shift;
        my (@c, @t, @h, @v);
        $aref = [ $aref ] unless reftype($aref) eq 'ARRAY';
        foreach my $href ( @$aref )
        {
            push @c, $href->{ComponentIdentifier};
            push @h, $href->{HorizontalSamplingFactor};
            push @v, $href->{VerticalSamplingFactor};
            push @t, ( $href->{HorizontalSamplingFactor} *
                       $href->{VerticalSamplingFactor} );
        }

        local $" = ":";
        return "@c @t (Horiz=@h, Vert=@v)";
    };

    my $chars_to_hex = sub
    {
        my ( $blob, $max_lines ) = @_;
        my @output;
        while (length $blob)
        {
            my $chunk = substr $blob, 0, 32, '';
            push @output, unpack "H*", $chunk;
        }

        if ( $max_lines )
        {
            my $excess_lines = @output - $max_lines;
            if ( $excess_lines > 0 )
            {
                $#output = $max_lines-1;
                push @output, "[omitting $excess_lines lines]"
            }
        }

        return join "\n", @output;
    };

    my $dump_whatever;

    my $dump_array = sub
    {
        my $aref = shift;
        return '[ ' . join(' ', map $dump_whatever->($_), @$aref ) . ' ]';
    };

    my $dump_hash = sub
    {
        my $href = shift;
        return '{ ' . join(', ', map( { "$_ => " . $dump_whatever->($href->{$_}) }
                                      sort keys %$href) ) . ' }';
    };

    $dump_whatever = sub
    {
        my $thingy = shift;
        if ( my $rt = reftype $thingy)
        {
            if ( $rt eq 'ARRAY' ) { return $dump_array->($thingy) }
            if ( $rt eq 'HASH'  ) { return $dump_hash->($thingy) }
            else                  { return "$thingy" }
        }
        else
        {
            return $thingy;
        }
    };

    my %action_for =
      (
       'ApertureValue' => [ $rational, 1 ],
       'BitsPerSample' => $dump_whatever,
       'ColorComponents' => undef,
       'ColorComponentsDecoded' => $decode_color_components,
       # 'ComponentsConfiguration' => $chars_to_int,
       'ExposureIndex' => $rational,
       'FNumber' => [ $rational, 1 ],
       # 'FileSource' => $chars_to_int,
       'FocalLength' => [ $rational, 1 ],
       'MakerNote' => [ $chars_to_hex, 10 ],
       'MaxApertureValue' => [ $rational, 1 ],
       # 'SceneType' => $chars_to_int,
       'ShutterSpeedValue' => [ $rational, 1 ],
       'SubjectDistance' => [ $rational, 2 ],
       'App13-Photo' => [ $chars_to_hex, 10 ],
      );

    my %simplified_value_of;
    foreach my $key (keys %$info_href)
    {
        my $value = $info_href->{$key};

        unless (exists $action_for{$key})
        {
            if ( ref($value) && reftype($value) eq 'ARRAY' )
            {
                $simplified_value_of{$key} =
                  '[ ' . join( ' ', @$value ) . ' ]';
                next;
            }

            my $value_str = $value . ""; # stringify

            # check for non-printable characters
            if ( $value_str =~ /[^ \x0a \x0d
                                   \x20-\x7e
                                   \xa0-\xff ]/x )
            {
                # if there are any, make it a hex string
                $simplified_value_of{$key} = $chars_to_hex->($value);
            }
            else
            {
                # otherwise, just use stringified value
                $simplified_value_of{$key} = $value_str;
            }
            next;
        }

        my $action = $action_for{$key};
        next unless defined $action; # undef action means "skip"

        my @extra_args;
        if (ref($action) =~ /^ARRAY/ )
        {
            @extra_args = @$action;
            $action = shift @extra_args;
        }

        $simplified_value_of{$key} = $action->($value, @extra_args);
    }

    return \%simplified_value_of;
}

# return the file size, formatted nicely.
sub pretty_file_size ( $ )
{
    my $file = shift;
    return "<unknown>" unless -e $file;
    my $size = -s _;
    my @prefixes = ( '', 'Ki', 'Mi', 'Gi', 'Ti' );
    while ($size > 1024)
    {
        $size /= 1024;
        shift @prefixes;
    }

    return sprintf "%.1f %sB", $size, $prefixes[0];
}

# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# indent-tabs-mode: nil
# End: