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 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 ### Image types.
  98
  99 our %TYPE;
 100
 101 package TrivGal::ImageType {
 102   sub new ($$) {
 103     my ($cls, $ext) = @_;
 104     return $TYPE{$ext} = bless { ext => $ext }, $cls;
 105   }
 106   sub ext ($) {
 107     my ($me, @args) = @_;
 108     return $me->{ext};
 109   }
 110   sub mimetype ($@) {
 111     my ($me, @args) = @_;
 112     return TrivGal::read_or_set $me, $me->{mimetype}, @args;
 113   }
 114   sub imlibfmt ($@) {
 115     my ($me, @args) = @_;
 116     return TrivGal::read_or_set $me, $me->{imlibfmt}, @args;
 117   }
 118 }
 119
 120 TrivGal::ImageType->new(".jpg")->mimetype("image/jpeg")->imlibfmt("jpeg");
 121 TrivGal::ImageType->new(".png")->mimetype("image/png")->imlibfmt("png");
 122
 123 ###--------------------------------------------------------------------------
 124 ### Configuration.
 125
 126 export qw{$SCOPE $SUFFIX};
 127 our $SCOPE //= $::SCOPE;
 128 our $SUFFIX //= $::SUFFIX;
 129
 130 export qw{$IMGROOT $CACHE $TMP};
 131 our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
 132 our $CACHE //=
 133   ($ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache") .
 134   "/tgal/$SCOPE$SUFFIX";
 135 our $TMP //= "$CACHE/tmp";
 136
 137 export qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
 138 my $user = getpwuid($>)->name;
 139 our $ROOTURL //= "/~$user";
 140 our $IMGURL //= "$ROOTURL/tgal-images";
 141 our $CACHEURL //= "$ROOTURL/tgal-cache";
 142 our $STATICURL //= "$ROOTURL/tgal-static";
 143 our $SCRIPTURL;
 144
 145 export qw{$SRCURL};
 146 our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/";
 147
 148 export qw{%SIZE};
 149 our %SIZE = (smallthumb => 96,
 150              medthumb => 144,
 151              bigthumb => 228,
 152              small => 480,
 153              embed => 720,
 154              view => 1200);
 155
 156 export qw{init};
 157 my $initp = 0;
 158 sub init () {
 159   my $m = HTML::Mason::Request->instance;
 160   my $r = $m->cgi_request;
 161
 162   $m->interp->set_escape(u => sub { my ($r) = @_; $$r = urlencode $$r; });
 163
 164   return unless !$initp;
 165
 166   $SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
 167   $initp = 1;
 168 }
 169
 170 ###--------------------------------------------------------------------------
 171 ### Temporary files.
 172
 173 export qw{clean_temp_files};
 174 sub clean_temp_files () {
 175   my $d;
 176
 177   eval { opendir $d, $TMP; };
 178   if ($@) {
 179     if ($@->isa("autodie::exception") && $@->errno == ENOENT) { return; }
 180     else { die $@; }
 181   }
 182   my $now = time;
 183   FILE: while (my $name = readdir $d) {
 184     next FILE unless $name =~ /^t(\d+)\-/;
 185     my $pid = $1;
 186     next FILE if kill 0, $pid;
 187     my $f = "$TMP/$name";
 188     my $st = stat $name;
 189     next FILE if $now - $st->mtime() < 300;
 190     unlink $f;
 191   }
 192   closedir $d;
 193 }
 194
 195 ###--------------------------------------------------------------------------
 196 ### Scaled images.
 197
 198 my %ORIENT =
 199   (1 => [0, 0],
 200    2 => [0, 1],
 201    3 => [2, 0],
 202    4 => [2, 1],
 203    5 => [3, 1],
 204    6 => [1, 0],
 205    7 => [1, 1],
 206    8 => [3, 0]);
 207
 208 package TrivGal::Image {
 209   use File::Path qw{make_path};
 210   use File::stat;
 211
 212   sub new ($$) {
 213     my ($cls, $path) = @_;
 214     my $imgpath = "$IMGROOT/$path";
 215     my $st = stat $imgpath or die "no image `$path'";
 216     return bless {
 217       path => $path, imgpath => $imgpath,
 218       mtime => $st->mtime,
 219       img => undef,
 220       _wd => undef, _ht => undef,
 221       sz => undef
 222     }, $cls;
 223   }
 224
 225   sub _getsz ($) {
 226     my ($me) = @_;
 227     return if defined $me->{_wd};
 228
 229     my ($wd, $ht, $err) = Image::Size::imgsize $me->{imgpath};
 230     defined $wd or die "failed to read size of `$me->{path}': $err";
 231     my $sz = $wd; if ($sz < $ht) { $sz = $ht; }
 232     @$me{"_wd", "_ht", "sz"} = ($wd, $ht, $sz);
 233   }
 234
 235   sub sz ($) { my ($me) = @_; $me->_getsz; return $me->{sz}; }
 236
 237   sub scale ($$;$) {
 238     my ($me, $scale, $forcep) = @_;
 239     my $m = HTML::Mason::Request->instance;
 240
 241     my $path = $me->{path};
 242     my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
 243     if ($me->sz <= $sz)
 244       { return $m->interp->apply_escapes("$IMGURL/$path", "u"); }
 245
 246     my $tail = "scale.$sz/$path";
 247     my $thumb = "$CACHE/$tail";
 248     my $thumburl = $m->interp->apply_escapes("$CACHEURL/$tail", "u");
 249     my $st = stat $thumb;
 250     if (defined $st && $st->mtime > $me->{mtime}) { return $thumburl; }
 251     return
 252       $m->interp->apply_escapes("$SCRIPTURL/$path", "u") . "?scale=$scale"
 253       unless $forcep;
 254
 255     my ($dir, $base, $ext) = TrivGal::split_path $thumb;
 256     my $ty = $TYPE{lc $ext} or die "unknown type `$ext'";
 257
 258     my $img = $me->{img};
 259     unless (defined $img) {
 260       my $exif = new Image::ExifTool;
 261       $exif->ExtractInfo($me->{imgpath});
 262       my $orient = $exif->GetValue("Orientation", "ValueConv");
 263       $img = $me->{img} = Image::Imlib2->load($me->{imgpath});
 264       if (defined $orient) {
 265         my ($rot, $flip) = @{$ORIENT{$orient}};
 266         if ($rot) { $img->image_orientate($rot); }
 267         if ($flip) { $img->flip_horizontal(); }
 268       }
 269     }
 270
 271     my $sc = $sz/$me->sz;
 272     my $scaled = $img->create_scaled_image($sc*$wd, $sc*$ht);
 273
 274     $scaled->image_set_format($ty->imlibfmt);
 275     $scaled->set_quality(90);
 276     my $new = "$TMP/t$$-$ext";
 277     make_path $TMP, { mode => 0771 };
 278     $scaled->save($new);
 279     make_path $dir, { mode => 0771 };
 280     rename $new, $thumb;
 281     return $thumburl;
 282   }
 283 }
 284
 285 ###--------------------------------------------------------------------------
 286 ### Directory listings.
 287
 288 package TrivGal::Item {
 289   sub new ($$) {
 290     my ($cls, $name) = @_;
 291     return bless { name => $name }, $cls;
 292   }
 293   sub name ($@) {
 294     my ($me, @args) = @_;
 295     return TrivGal::read_or_set $me, $me->{name}, @args;
 296   }
 297   sub comment ($@) {
 298     my ($me, @args) = @_;
 299     return TrivGal::read_or_set $me, $me->{comment}, @args;
 300   }
 301 }
 302
 303 export qw{listdir};
 304 sub listdir ($) {
 305   my ($path) = @_;
 306   my (@d, @f);
 307   my $ix = undef;
 308
 309   $path =~ s#/$##;
 310   if (-f "$path/.tgal.index") {
 311     open my $f, "<", "$path/.tgal.index";
 312     my $item = undef;
 313     my $comment = undef;
 314     LINE: while (<$f>) {
 315       chomp;
 316       next LINE if /^\s*(\#|$)/;
 317       if (s/^\s+//) {
 318         die "no item" unless $item;
 319         $comment = defined $comment ? $comment . "\n" . $_ : $_;
 320       } else {
 321         if ($item && $comment) { $item->comment($comment); }
 322         my ($flags, $name, $c) =
 323           /^ (?: ([-!]+) \s+)?          # flags
 324              (\S+) \s*                  # filename
 325              (\S | \S.*\S )?            # start of the comment
 326              \s*
 327              $/x;
 328         my $indexp = $flags =~ /!/;
 329         my $hidep = $flags =~ /-/;
 330         $name = urldecode $name;
 331         my $list;
 332         $item = TrivGal::Item->new($name);
 333         if ($name =~ m#/$#) {
 334           $list = \@d;
 335           die "can't index a folder" if $indexp;
 336         } else {
 337           $list = \@f;
 338           my ($dir, $base, $ext) = split_path $name;
 339           die "unknown image type" unless $TYPE{lc $ext};
 340           if ($indexp) {
 341             die "two index images" if defined $ix;
 342             $ix = $item;
 343           }
 344         }
 345         $comment = $c;
 346         push @$list, $item unless $hidep;
 347       }
 348     }
 349     if ($item && $comment) { $item->comment($comment); }
 350     close $f;
 351   } else {
 352     my $st = stat $path;
 353     unless ($st->mode&0004) { return ([], [], undef); }
 354
 355     opendir $d, $path;
 356     my @e = readdir $d;
 357     closedir $d;
 358
 359     ENT: for my $e (sort @e) {
 360       my ($dir, $base, $ext) = split_path $e;
 361       my $dotp = $e =~ /^\./;
 362       my $st = stat "$path/$e";
 363       my $list = undef;
 364       if ($dotp) { }
 365       elsif (-d $st) { $list = \@d; $e .= "/"; }
 366       elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; }
 367       $list and push @$list, TrivGal::Item->new($e);
 368     }
 369     $ix = $f[0] if @f;
 370   }
 371
 372   return (\@d, \@f, $ix);
 373 }
 374
 375 export qw{contents};
 376 sub contents ($) {
 377   my ($file) = @_;
 378   my $contents = "";
 379   my $f;
 380   local $@;
 381   eval { open $f, "<", "$file"; };
 382   if ($@) {
 383     if ($@->isa("autodie::exception") && $@->errno == ENOENT)
 384       { return undef; }
 385     die $@;
 386   }
 387   while (sysread $f, $buf, 16384) { $contents .= $buf; }
 388   close $f;
 389   return $contents;
 390 }
 391
 392 export qw{find_covering_file};
 393 sub find_covering_file ($$$) {
 394   my ($top, $path, $name) = @_;
 395   for (;;) {
 396     my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff;
 397     if ($path eq "") { return undef; }
 398     if ($path =~ m#^(.*)/[^/]+/?#) { $path = $1; }
 399     else { $path = ""; }
 400   }
 401 }
 402
 403 ###----- That's all, folks --------------------------------------------------
 404
 405 clean_temp_files;
 406
 407 1;