chiark - git - mdw - tgal/blob - mason/.perl-lib/TrivGal.pm

   1 ### -*-cperl-*-
   2 ###
   3 ### Main output for Trivial Gallery.
   4 ###
   5 ### (c) 2021 Mark Wooding
   6 ###
   7
   8 ###----- Licensing notice ---------------------------------------------------
   9 ###
  10 ### This file is part of Trivial Gallery.
  11 ###
  12 ### Trivial Gallery is free software: you can redistribute it and/or modify
  13 ### it under the terms of the GNU Affero General Public License as
  14 ### published by the Free Software Foundation; either version 3 of the
  15 ### License, or (at your option) any later version.
  16 ###
  17 ### Trivial Gallery is distributed in the hope that it will be useful, but
  18 ### WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ### Affero General Public License for more details.
  21 ###
  22 ### You should have received a copy of the GNU Affero General Public
  23 ### License along with Trivial Gallery.  If not, see
  24 ### <https://www.gnu.org/licenses/>.
  25
  26 package TrivGal;
  27
  28 use autodie qw{:all};
  29
  30 use Errno;
  31 use Exporter qw{import};
  32 use File::stat;
  33 use Image::ExifTool qw{};
  34 use Image::Imlib2;
  35 use User::pwent;
  36 use POSIX;
  37
  38 our @EXPORT;
  39 sub export (@) { push @EXPORT, @_; }
  40
  41 ###--------------------------------------------------------------------------
  42 ### Internal utilities.
  43
  44 sub read_or_set ($\$@) {
  45   my ($me, $ref, @args) = @_;
  46   if (@args == 0) { return $$ref; }
  47   elsif (@args == 1) { $$ref = $args[0]; return $me; }
  48   elsif (@args > 1) { die "too many arguments"; }
  49 }
  50
  51 ###--------------------------------------------------------------------------
  52 ### Random utilities.
  53
  54 export qw{join_paths};
  55 sub join_paths (@) {
  56   my @p = @_;
  57   my $p = "";
  58   ELT: for my $e (@p) {
  59     $e =~ s#^/{2,}#/#;
  60     $e =~ s#([^/])/+$#$1#;
  61     if ($e eq "") { next ELT; }
  62     elsif ($p eq "" || $e =~ m#^/#) { $p = $e; }
  63     else { $p = "$p/$e"; }
  64   }
  65   return $p;
  66 }
  67
  68 export qw{split_path};
  69 sub split_path ($) {
  70   my ($path) = @_;
  71
  72   my ($dir, $base, $ext) =
  73     $path =~ m#^ (?: (.*) /)?
  74                  (?: ([^/]*) \.)?
  75                  ([^./]*) $#x;
  76   if (defined $base) { $ext = ".$ext"; }
  77   else { $base = $ext; $ext = ""; }
  78   return ($dir, $base, $ext);
  79 }
  80
  81 export qw{urlencode};
  82 sub urlencode ($) {
  83   my ($u) = @_;
  84   $u =~ s#([^0-9a-zA-Z_./~-])#sprintf "%%%02x", ord $1#eg;
  85   return $u;
  86 }
  87
  88 export qw{urldecode};
  89 sub urldecode ($) {
  90   my ($u) = @_;
  91   $u =~ s#\%([0-9a-fA-F]{2})#chr hex $1#eg;
  92   return $u;
  93 }
  94
  95 ###--------------------------------------------------------------------------
  96 ### Image types.
  97
  98 our %TYPE;
  99
 100 package TrivGal::ImageType {
 101   sub new ($$) {
 102     my ($cls, $ext) = @_;
 103     return $TYPE{$ext} = bless { ext => $ext }, $cls;
 104   }
 105   sub ext ($) {
 106     my ($me, @args) = @_;
 107     return $me->{ext};
 108   }
 109   sub mimetype ($@) {
 110     my ($me, @args) = @_;
 111     return TrivGal::read_or_set $me, $me->{mimetype}, @args;
 112   }
 113   sub imlibfmt ($@) {
 114     my ($me, @args) = @_;
 115     return TrivGal::read_or_set $me, $me->{imlibfmt}, @args;
 116   }
 117 }
 118
 119 TrivGal::ImageType->new(".jpg")->mimetype("image/jpeg")->imlibfmt("jpeg");
 120 TrivGal::ImageType->new(".png")->mimetype("image/png")->imlibfmt("png");
 121
 122 ###--------------------------------------------------------------------------
 123 ### Configuration.
 124
 125 export qw{$SCOPE $SUFFIX};
 126 our $SCOPE //= $::SCOPE;
 127 our $SUFFIX //= $::SUFFIX;
 128
 129 export qw{$IMGROOT $CACHE $TMP};
 130 our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
 131 our $CACHE //=
 132   ($ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache") .
 133   "/tgal/$SCOPE$SUFFIX";
 134 our $TMP //= "$CACHE/tmp";
 135
 136 export qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
 137 my $user = getpwuid($>)->name;
 138 our $ROOTURL //= "/~$user";
 139 our $IMGURL //= "$ROOTURL/tgal-images";
 140 our $CACHEURL //= "$ROOTURL/tgal-cache";
 141 our $STATICURL //= "$ROOTURL/tgal-static";
 142 our $SCRIPTURL;
 143
 144 export qw{$SRCURL};
 145 our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/";
 146
 147 export qw{%SIZE};
 148 our %SIZE = (smallthumb => 96,
 149              medthumb => 144,
 150              bigthumb => 228,
 151              small => 480,
 152              embed => 720,
 153              view => 1200);
 154
 155 export qw{init};
 156 my $initp = 0;
 157 sub init () {
 158   my $m = HTML::Mason::Request->instance;
 159   my $r = $m->cgi_request;
 160
 161   $m->interp->set_escape(u => sub { my ($r) = @_; $$r = urlencode $$r; });
 162
 163   return unless !$initp;
 164
 165   $SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
 166   $initp = 1;
 167 }
 168
 169 ###--------------------------------------------------------------------------
 170 ### Temporary files.
 171
 172 export qw{clean_temp_files};
 173 sub clean_temp_files () {
 174   my $d;
 175
 176   eval { opendir $d, $TMP; };
 177   if ($@) {
 178     if ($@->isa("autodie::exception") && $@->errno == ENOENT) { return; }
 179     else { die $@; }
 180   }
 181   my $now = time;
 182   FILE: while (my $name = readdir $d) {
 183     next FILE unless $name =~ /^t(\d+)\-/;
 184     my $pid = $1;
 185     next FILE if kill 0, $pid;
 186     my $f = "$TMP/$name";
 187     my $st = stat $name;
 188     next FILE if $now - $st->mtime() < 300;
 189     unlink $f;
 190   }
 191   closedir $d;
 192 }
 193
 194 ###--------------------------------------------------------------------------
 195 ### Scaled images.
 196
 197 my %ORIENT =
 198   (1 => [0, 0],
 199    2 => [0, 1],
 200    3 => [2, 0],
 201    4 => [2, 1],
 202    5 => [3, 1],
 203    6 => [1, 0],
 204    7 => [1, 1],
 205    8 => [3, 0]);
 206
 207 package TrivGal::Image {
 208   use File::Path qw{make_path};
 209   use File::stat;
 210
 211   sub new ($$) {
 212     my ($cls, $path) = @_;
 213     my $imgpath = "$IMGROOT/$path";
 214     my $st = stat $imgpath or die "no image `$path'";
 215     return bless {
 216       path => $path,
 217       mtime => $st->mtime,
 218       img => undef
 219     }, $cls;
 220   }
 221
 222   sub scale ($$;$) {
 223     my ($me, $scale, $forcep) = @_;
 224     my $m = HTML::Mason::Request->instance;
 225
 226     my $path = $me->{path};
 227     my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
 228     my $thumb = "$CACHE/scale.$sz/$path";
 229     my $thumburl =
 230       $m->interp->apply_escapes("$CACHEURL/scale.$sz/$path", "u");
 231     my $st = stat $thumb;
 232     if (defined $st && $st->mtime > $me->{mtime}) { return $thumburl; }
 233     return
 234       $m->interp->apply_escapes("$SCRIPTURL/$path", "u") . "?scale=$scale"
 235       unless $forcep;
 236
 237     my ($dir, $base, $ext) = TrivGal::split_path $thumb;
 238     my $ty = $TYPE{lc $ext} or die "unknown type `$ext'";
 239
 240     my $img = $me->{img};
 241     unless (defined $img) {
 242       my $imgpath = "$IMGROOT/$path";
 243       my $exif = new Image::ExifTool;
 244       $exif->ExtractInfo($imgpath);
 245       my $orient = $exif->GetValue("Orientation", "ValueConv");
 246       $img = $me->{img} = Image::Imlib2->load($imgpath);
 247       if (defined $orient) {
 248         my ($rot, $flip) = @{$ORIENT{$orient}};
 249         if ($rot) { $img->image_orientate($rot); }
 250         if ($flip) { $img->flip_horizontal(); }
 251       }
 252     }
 253
 254     my ($wd, $ht) = ($img->width, $img->height);
 255     my $max = $wd > $ht ? $wd : $ht;
 256     if ($max <= $sz) { return "$IMGURL/$path"; }
 257     my $sc = $sz/$max;
 258     my $scaled = $img->create_scaled_image($sc*$wd, $sc*$ht);
 259
 260     $scaled->image_set_format($ty->imlibfmt);
 261     $scaled->set_quality(90);
 262     my $new = "$TMP/t$$-$ext";
 263     make_path $TMP;
 264     $scaled->save($new);
 265     make_path $dir;
 266     rename $new, $thumb;
 267     return $thumburl;
 268   }
 269 }
 270
 271 ###--------------------------------------------------------------------------
 272 ### Directory listings.
 273
 274 package TrivGal::Item {
 275   sub new ($$) {
 276     my ($cls, $name) = @_;
 277     return bless { name => $name }, $cls;
 278   }
 279   sub name ($@) {
 280     my ($me, @args) = @_;
 281     return TrivGal::read_or_set $me, $me->{name}, @args;
 282   }
 283   sub comment ($@) {
 284     my ($me, @args) = @_;
 285     return TrivGal::read_or_set $me, $me->{comment}, @args;
 286   }
 287 }
 288
 289 export qw{listdir};
 290 sub listdir ($) {
 291   my ($path) = @_;
 292   my (@d, @f);
 293   my $ix = undef;
 294
 295   $path =~ s#/$##;
 296   if (-f "$path/.tgal.index") {
 297     open my $f, "<", "$path/.tgal.index";
 298     my $item = undef;
 299     my $comment = undef;
 300     LINE: while (<$f>) {
 301       chomp;
 302       next LINE if /^\s*(\#|$)/;
 303       if (s/^\s+//) {
 304         die "no item" unless $item;
 305         $comment = defined $comment ? $comment . "\n" . $_ : $_;
 306       } else {
 307         if ($item && $comment) { $item->comment($comment); }
 308         my ($flags, $name, $c) =
 309           /^ (?: ([-!]+) \s+)?          # flags
 310              (\S+) \s*                  # filename
 311              (\S | \S.*\S )?            # start of the comment
 312              \s*
 313              $/x;
 314         my $indexp = $flags =~ /!/;
 315         my $hidep = $flags =~ /-/;
 316         $name = urldecode $name;
 317         my $list;
 318         $item = TrivGal::Item->new($name);
 319         if ($name =~ m#/$#) {
 320           $list = \@d;
 321           die "can't index a folder" if $indexp;
 322         } else {
 323           $list = \@f;
 324           my ($dir, $base, $ext) = split_path $name;
 325           die "unknown image type" unless $TYPE{lc $ext};
 326           if ($indexp) {
 327             die "two index images" if defined $ix;
 328             $ix = $item;
 329           }
 330         }
 331         $comment = $c;
 332         push @$list, $item unless $hidep;
 333       }
 334     }
 335     if ($item && $comment) { $item->comment($comment); }
 336     close $f;
 337   } else {
 338     my $st = stat $path;
 339     unless ($st->mode&0004) { return ([], [], undef); }
 340
 341     opendir $d, $path;
 342     my @e = readdir $d;
 343     closedir $d;
 344
 345     ENT: for my $e (sort @e) {
 346       my ($dir, $base, $ext) = split_path $e;
 347       my $dotp = $e =~ /^\./;
 348       my $st = stat "$path/$e";
 349       my $list = undef;
 350       if ($dotp) { }
 351       elsif (-d $st) { $list = \@d; $e .= "/"; }
 352       elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; }
 353       $list and push @$list, TrivGal::Item->new($e);
 354     }
 355     $ix = $f[0] if @f;
 356   }
 357
 358   return (\@d, \@f, $ix);
 359 }
 360
 361 export qw{contents};
 362 sub contents ($) {
 363   my ($file) = @_;
 364   my $contents = "";
 365   my $f;
 366   local $@;
 367   eval { open $f, "<", "$file"; };
 368   if ($@) {
 369     if ($@->isa("autodie::exception") && $@->errno == ENOENT)
 370       { return undef; }
 371     die $@;
 372   }
 373   while (sysread $f, $buf, 16384) { $contents .= $buf; }
 374   close $f;
 375   return $contents;
 376 }
 377
 378 export qw{find_covering_file};
 379 sub find_covering_file ($$$) {
 380   my ($top, $path, $name) = @_;
 381   for (;;) {
 382     my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff;
 383     if ($path eq "") { return undef; }
 384     if ($path =~ m#^(.*)/[^/]+/?#) { $path = $1; }
 385     else { $path = ""; }
 386   }
 387 }
 388
 389 ###----- That's all, folks --------------------------------------------------
 390
 391 clean_temp_files;
 392
 393 1;