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 Graphics::Magick;
  34 use Image::ExifTool qw{};
  35 use Image::Size qw{};
  36 use User::pwent;
  37 use POSIX;
  38
  39 our @EXPORT;
  40 sub export (@) { push @EXPORT, @_; }
  41
  42 ###--------------------------------------------------------------------------
  43 ### Internal utilities.
  44
  45 sub read_or_set ($\$@) {
  46   my ($me, $ref, @args) = @_;
  47   if (@args == 0) { return $$ref; }
  48   elsif (@args == 1) { $$ref = $args[0]; return $me; }
  49   elsif (@args > 1) { die "too many arguments"; }
  50 }
  51
  52 ###--------------------------------------------------------------------------
  53 ### Random utilities.
  54
  55 export qw{join_paths};
  56 sub join_paths (@) {
  57   my @p = @_;
  58   my $p = "";
  59   ELT: for my $e (@p) {
  60     $e =~ s#^/{2,}#/#;
  61     $e =~ s#([^/])/+$#$1#;
  62     if ($e eq "") { next ELT; }
  63     elsif ($p eq "" || $e =~ m#^/#) { $p = $e; }
  64     else { $p = "$p/$e"; }
  65   }
  66   return $p;
  67 }
  68
  69 export qw{split_path};
  70 sub split_path ($) {
  71   my ($path) = @_;
  72
  73   my ($dir, $base, $ext) =
  74     $path =~ m#^ (?: (.*) /)?
  75                  (?: ([^/]*) \.)?
  76                  ([^./]*) $#x;
  77   if (defined $base) { $ext = ".$ext"; }
  78   else { $base = $ext; $ext = ""; }
  79   return ($dir, $base, $ext);
  80 }
  81
  82 export qw{urlencode};
  83 sub urlencode ($) {
  84   my ($u) = @_;
  85   $u =~ s#([^0-9a-zA-Z_./~-])#sprintf "%%%02x", ord $1#eg;
  86   return $u;
  87 }
  88
  89 export qw{urldecode};
  90 sub urldecode ($) {
  91   my ($u) = @_;
  92   $u =~ s#\%([0-9a-fA-F]{2})#chr hex $1#eg;
  93   return $u;
  94 }
  95
  96 ###--------------------------------------------------------------------------
  97 ### Configuration.
  98
  99 export qw{$SCOPE $SUFFIX};
 100 our $SCOPE //= $::SCOPE;
 101 our $SUFFIX //= $::SUFFIX;
 102
 103 export qw{$IMGROOT $CACHE $TMP};
 104 our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
 105 our $CACHE //=
 106   ($ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache") .
 107   "/tgal/$SCOPE$SUFFIX";
 108 our $TMP //= "$CACHE/tmp";
 109
 110 export qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
 111 my $user = getpwuid($>)->name;
 112 our $ROOTURL //= "/~$user";
 113 our $IMGURL //= "$ROOTURL/tgal-images";
 114 our $CACHEURL //= "$ROOTURL/tgal-cache";
 115 our $STATICURL //= "$ROOTURL/tgal-static";
 116 our $SCRIPTURL;
 117
 118 export qw{$SRCURL};
 119 our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/";
 120
 121 export qw{%SIZE};
 122 our %SIZE = (smallthumb => 96,
 123              medthumb => 144,
 124              bigthumb => 216,
 125              tiny => 320,
 126              small => 480,
 127              embed => 720,
 128              medium => 1080,
 129              big => 1600,
 130              large => 2400,
 131              huge => 3600,
 132              vast => 5400,
 133              immense => 8100);
 134
 135 export qw{%TYPE};
 136 our %TYPE = map { $_ => 1 } qw{.jpg .png};
 137
 138 export qw{init};
 139 my $initp = 0;
 140 sub init () {
 141   my $m = HTML::Mason::Request->instance;
 142   my $r = $m->cgi_request;
 143
 144   $m->interp->set_escape(u => sub { my ($r) = @_; $$r = urlencode $$r; });
 145
 146   return unless !$initp;
 147
 148   $SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
 149   $initp = 1;
 150 }
 151
 152 ###--------------------------------------------------------------------------
 153 ### Temporary files.
 154
 155 export qw{clean_temp_files};
 156 sub clean_temp_files () {
 157   no autodie qw{kill opendir unlink};
 158   my $d;
 159
 160   unless (opendir $d, $TMP) {
 161     if ($! == ENOENT) { return }
 162     else { die "failed to read temporary directory `$TMP': $!"; }
 163   }
 164   my $now = time;
 165   FILE: while (my $name = readdir $d) {
 166     next FILE unless $name =~ /^t(\d+)\-/;
 167     my $pid = $1;
 168     next FILE if kill 0, $pid;
 169     my $f = "$TMP/$name";
 170     my $st = stat $f;
 171     if (!defined $st) {
 172       if ($! == ENOENT) { next FILE; }
 173       else { die "failed to read file metadata for `$f': $!"; }
 174     }
 175     next FILE if $now - $st->mtime() < 300;
 176     unless (unlink $f) {
 177       if ($! == ENOENT) { next FILE; }
 178       else { die "failed to delete file `$f': $!"; }
 179     }
 180   }
 181   closedir $d;
 182 }
 183
 184 ###--------------------------------------------------------------------------
 185 ### Scaled images.
 186
 187 my %ORIENT =
 188   (1 => [0, 0],
 189    2 => [0, 1],
 190    3 => [2, 0],
 191    4 => [2, 1],
 192    5 => [3, 1],
 193    6 => [1, 0],
 194    7 => [1, 1],
 195    8 => [3, 0]);
 196
 197 package TrivGal::Image {
 198   use File::Path qw{make_path};
 199   use File::stat;
 200
 201   sub new ($$) {
 202     my ($cls, $path) = @_;
 203     my $imgpath = "$IMGROOT/$path";
 204     my $st = stat $imgpath or die "no image `$path'";
 205     return bless {
 206       path => $path, imgpath => $imgpath,
 207       mtime => $st->mtime,
 208       img => undef,
 209       rot => undef, flip => undef,
 210       wd => undef, ht => undef,
 211       _wd => undef, _ht => undef,
 212       sz => undef
 213     }, $cls;
 214   }
 215
 216   sub _getsz ($) {
 217     my ($me) = @_;
 218     return if defined $me->{_wd};
 219
 220     my ($wd, $ht, $err) = Image::Size::imgsize $me->{imgpath};
 221     defined $wd or die "failed to read size of `$me->{path}': $err";
 222     my $sz = $wd; if ($sz < $ht) { $sz = $ht; }
 223     @$me{"_wd", "_ht", "sz"} = ($wd, $ht, $sz);
 224   }
 225
 226   sub _getexif ($) {
 227     my ($me) = @_;
 228     return if defined $me->{wd};
 229
 230     $me->_getsz;
 231     my $exif = new Image::ExifTool; $exif->ExtractInfo($me->{imgpath});
 232     my $orient = $exif->GetValue("Orientation", "ValueConv");
 233     my ($wd, $ht) = @$me{"_wd", "_ht"};
 234     my ($rot, $flip);
 235     if (defined $orient) { ($rot, $flip) = $ORIENT{$orient}->@*; }
 236     else { ($rot, $flip) = (0, 0); }
 237     if ($rot%2) { ($wd, $ht) = ($ht, $wd); }
 238     @$me{"rot", "flip", "wd", "ht"} = ($rot, $flip, $wd, $ht);
 239   }
 240
 241   sub sz ($) { my ($me) = @_; $me->_getsz; return $me->{sz}; }
 242   sub wd ($) { my ($me) = @_; $me->_getexif; return $me->{wd}; }
 243   sub ht ($) { my ($me) = @_; $me->_getexif; return $me->{ht}; }
 244
 245   sub _check_gm ($) {
 246     my ($rc) = @_;
 247     "$rc" and die "failed to hack `$me->{img}': $rc";
 248   }
 249
 250   sub scale ($$;$) {
 251     my ($me, $scale, $forcep) = @_;
 252     my $m = HTML::Mason::Request->instance;
 253
 254     my $path = $me->{path};
 255     my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
 256     my $url;
 257
 258     if ($me->sz <= $sz)
 259       { $url = $m->interp->apply_escapes("$IMGURL/$path", "u"); }
 260     else {
 261       my $tail = "scale.$sz/$path";
 262       my $thumb = "$CACHE/$tail";
 263       my $thumburl = $m->interp->apply_escapes("$CACHEURL/$tail", "u");
 264
 265       my $st = stat $thumb;
 266       if ($st && $st->mtime > $me->{mtime})
 267         { $url = $thumburl; }
 268       elsif (!$forcep) {
 269         $url =
 270           $m->interp->apply_escapes("$SCRIPTURL/$path", "u") .
 271           "?scale=$scale";
 272       } else {
 273         my $img = $me->{img};
 274         unless (defined $img) {
 275           $img = $me->{img} = Graphics::Magick->new;
 276           _check_gm $img->Read($me->{imgpath});
 277         }
 278
 279         my ($dir, undef, $ext) = TrivGal::split_path $thumb;
 280         $img = $img->Clone;
 281         my $new = "$TMP/t$$-thumb$ext";
 282         _check_gm $img->Resize(geometry => $sz);
 283         make_path $TMP, { mode => 0771 };
 284         _check_gm $img->Write($new);
 285         make_path $dir, { mode => 0771 };
 286         rename $new, $thumb;
 287         $url = $thumburl;
 288       }
 289     }
 290
 291     return $url;
 292   }
 293 }
 294
 295 ###--------------------------------------------------------------------------
 296 ### Directory listings.
 297
 298 package TrivGal::Item {
 299   sub new ($$) {
 300     my ($cls, $name) = @_;
 301     return bless { name => $name }, $cls;
 302   }
 303   sub name ($@) {
 304     my ($me, @args) = @_;
 305     return TrivGal::read_or_set $me, $me->{name}, @args;
 306   }
 307   sub comment ($@) {
 308     my ($me, @args) = @_;
 309     return TrivGal::read_or_set $me, $me->{comment}, @args;
 310   }
 311 }
 312
 313 export qw{listdir};
 314 sub listdir ($) {
 315   my ($path) = @_;
 316   my (@d, @f);
 317   my $ix = undef;
 318
 319   $path =~ s#/$##;
 320   if (-f "$path/.tgal.index") {
 321     open my $f, "<", "$path/.tgal.index";
 322     my $item = undef;
 323     my $comment = undef;
 324     LINE: while (<$f>) {
 325       chomp;
 326       next LINE if /^\s*(\#|$)/;
 327       if (s/^\s+//) {
 328         die "no item" unless $item;
 329         $comment = defined $comment ? $comment . "\n" . $_ : $_;
 330       } else {
 331         if ($item && $comment) { $item->comment($comment); }
 332         my ($flags, $name, $c) =
 333           /^ (?: ([-!]+) \s+)?          # flags
 334              (\S+) \s*                  # filename
 335              (\S | \S.*\S )?            # start of the comment
 336              \s*
 337              $/x;
 338         my $indexp = $flags =~ /!/;
 339         my $hidep = $flags =~ /-/;
 340         $name = urldecode $name;
 341         my $list;
 342         $item = TrivGal::Item->new($name);
 343         if ($name =~ m#/$#) {
 344           $list = \@d;
 345           die "can't index a folder" if $indexp;
 346         } else {
 347           $list = \@f;
 348           my (undef, undef, $ext) = split_path $name;
 349           die "unknown image type" unless $TYPE{lc $ext};
 350           if ($indexp) {
 351             die "two index images" if defined $ix;
 352             $ix = $item;
 353           }
 354         }
 355         $comment = $c;
 356         push @$list, $item unless $hidep;
 357       }
 358     }
 359     if ($item && $comment) { $item->comment($comment); }
 360     close $f;
 361   } else {
 362     my $st = stat $path;
 363     unless ($st->mode&0004) { return ([], [], undef); }
 364
 365     opendir $d, $path;
 366     my @e = readdir $d;
 367     closedir $d;
 368
 369     ENT: for my $e (sort @e) {
 370       my (undef, undef, $ext) = split_path $e;
 371       my $dotp = $e =~ /^\./;
 372       my $st = stat "$path/$e";
 373       my $list = undef;
 374       if ($dotp) { }
 375       elsif (-d $st) { $list = \@d; $e .= "/"; }
 376       elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; }
 377       $list and push @$list, TrivGal::Item->new($e);
 378     }
 379     $ix = $f[0] if @f;
 380   }
 381
 382   return (\@d, \@f, $ix);
 383 }
 384
 385 export qw{contents};
 386 sub contents ($) {
 387   my ($file) = @_;
 388   my $contents = "";
 389   my $f;
 390   local $@;
 391   eval { open $f, "<", "$file"; };
 392   if ($@) {
 393     if ($@->isa("autodie::exception") && $@->errno == ENOENT)
 394       { return undef; }
 395     die $@;
 396   }
 397   while (sysread $f, $buf, 16384) { $contents .= $buf; }
 398   close $f;
 399   return $contents;
 400 }
 401
 402 export qw{find_covering_file};
 403 sub find_covering_file ($$$) {
 404   my ($top, $path, $name) = @_;
 405   for (;;) {
 406     my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff;
 407     if ($path eq "") { return undef; }
 408     if ($path =~ m#^(.*)/[^/]+/?#) { $path = $1; }
 409     else { $path = ""; }
 410   }
 411 }
 412
 413 ###----- That's all, folks --------------------------------------------------
 414
 415 1;