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::Imlib2;
  34 use User::pwent;
  35 use POSIX;
  36
  37 our @EXPORT;
  38 sub export (@) { push @EXPORT, @_; }
  39
  40 ###--------------------------------------------------------------------------
  41 ### Internal utilities.
  42
  43 sub read_or_set ($\$@) {
  44   my ($me, $ref, @args) = @_;
  45   if (@args == 0) { return $$ref; }
  46   elsif (@args == 1) { $$ref = $args[0]; return $me; }
  47   elsif (@args > 1) { die "too many arguments"; }
  48 }
  49
  50 ###--------------------------------------------------------------------------
  51 ### Random utilities.
  52
  53 export qw{join_paths};
  54 sub join_paths (@) {
  55   my @p = @_;
  56   my $p = "";
  57   ELT: for my $e (@p) {
  58     $e =~ s:^/{2,}:/:;
  59     $e =~ s,([^/])/+$,$1,;
  60     if ($e eq "") { next ELT; }
  61     elsif ($p eq "" || $e =~ m,^/,) { $p = $e; }
  62     else { $p = "$p/$e"; }
  63   }
  64   return $p;
  65 }
  66
  67 export qw{split_path};
  68 sub split_path ($) {
  69   my ($path) = @_;
  70
  71   my ($dir, $base, $ext) = $path =~ m,^(?:(.*)/)?(?:([^/]*)\.)?([^./]*)$,;
  72   if (defined $base) { $ext = ".$ext"; }
  73   else { $base = $ext; $ext = ""; }
  74   return ($dir, $base, $ext);
  75 }
  76
  77 export qw{urlencode};
  78 sub urlencode ($) {
  79   my ($u) = @_;
  80   $u =~ s:([^0-9a-zA-Z_./~-]):sprintf "%%%02x", ord $1:eg;
  81   return $u;
  82 }
  83
  84 export qw{urldecode};
  85 sub urldecode ($) {
  86   my ($u) = @_;
  87   $u =~ s:\%([0-9a-fA-F]{2}):chr hex $1:eg;
  88   return $u;
  89 }
  90
  91 ###--------------------------------------------------------------------------
  92 ### Image types.
  93
  94 our %TYPE;
  95
  96 package TrivGal::ImageType {
  97   sub new ($$) {
  98     my ($cls, $ext) = @_;
  99     return $TYPE{$ext} = bless { ext => $ext }, $cls;
 100   }
 101   sub ext ($) {
 102     my ($me, @args) = @_;
 103     return $me->{ext};
 104   }
 105   sub mimetype ($@) {
 106     my ($me, @args) = @_;
 107     return TrivGal::read_or_set $me, $me->{mimetype}, @args;
 108   }
 109   sub imlibfmt ($@) {
 110     my ($me, @args) = @_;
 111     return TrivGal::read_or_set $me, $me->{imlibfmt}, @args;
 112   }
 113 }
 114
 115 TrivGal::ImageType->new(".jpg")->mimetype("image/jpeg")->imlibfmt("jpeg");
 116 TrivGal::ImageType->new(".png")->mimetype("image/png")->imlibfmt("png");
 117
 118 ###--------------------------------------------------------------------------
 119 ### Configuration.
 120
 121 export qw{$SCOPE $SUFFIX};
 122 our $SCOPE //= $::SCOPE;
 123 our $SUFFIX //= $::SUFFIX;
 124
 125 export qw{$IMGROOT $CACHE $TMP};
 126 our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
 127 our $CACHE //=
 128   ($ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache") .
 129   "/tgal/$SCOPE$SUFFIX";
 130 our $TMP //= "$CACHE/tmp";
 131
 132 export qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
 133 my $user = getpwuid($>)->name;
 134 our $ROOTURL //= "/~$user";
 135 our $IMGURL //= "$ROOTURL/tgal-images";
 136 our $CACHEURL //= "$ROOTURL/tgal-cache";
 137 our $STATICURL //= "$ROOTURL/tgal-static";
 138 our $SCRIPTURL;
 139
 140 export qw{%SIZE};
 141 our %SIZE = (smallthumb => 96,
 142              medthumb => 144,
 143              bigthumb => 228,
 144              view => 1200);
 145
 146 export qw{init};
 147 my $initp = 0;
 148 sub init () {
 149   my $m = HTML::Mason::Request->instance;
 150   my $r = $m->cgi_request;
 151
 152   $m->interp->set_escape(u => sub { my ($r) = @_; $$r = urlencode $$r; });
 153
 154   return unless !$initp;
 155
 156   $SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
 157   $initp = 1;
 158 }
 159
 160 ###--------------------------------------------------------------------------
 161 ### Temporary files.
 162
 163 export qw{clean_temp_files};
 164 sub clean_temp_files () {
 165   my $d;
 166
 167   eval { opendir $d, $TMP; };
 168   if ($@) {
 169     if ($@->isa("autodie::exception") && $@->errno == ENOENT) { return; }
 170     else { die $@; }
 171   }
 172   my $now = time;
 173   FILE: while (my $name = readdir $d) {
 174     next FILE unless $name =~ /^t(\d+)\-/;
 175     my $pid = $1;
 176     next FILE if kill 0, $pid;
 177     my $f = "$TMP/$name";
 178     my $st = stat $name;
 179     next FILE if $now - $st->mtime() < 300;
 180     unlink $f;
 181   }
 182   closedir $d;
 183 }
 184
 185 ###--------------------------------------------------------------------------
 186 ### Scaled images.
 187
 188 package TrivGal::Image {
 189   use File::Path qw{make_path};
 190   use File::stat;
 191
 192   sub new ($$) {
 193     my ($cls, $path) = @_;
 194     my $imgpath = "$IMGROOT/$path";
 195     my $st = stat $imgpath or die "no image `$path'";
 196     return bless {
 197       path => $path,
 198       mtime => $st->mtime,
 199       img => undef
 200     }, $cls;
 201   }
 202
 203   sub scale ($$) {
 204     my ($me, $scale) = @_;
 205
 206     my $path = $me->{path};
 207     my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
 208     my $thumb = "$CACHE/scale.$sz/$path";
 209     my $thumburl = "$CACHEURL/scale.$sz/$path";
 210     my $st = stat $thumb;
 211     if (defined $st && $st->mtime > $me->{mtime}) { return $thumburl; }
 212
 213     my ($dir, $base, $ext) = TrivGal::split_path $thumb;
 214     my $ty = $TYPE{lc $ext} or die "unknown type `$ext'";
 215
 216     my $img = $me->{img};
 217     unless (defined $img) {
 218       my $imgpath = "$IMGROOT/$path";
 219       $img = $me->{img} = Image::Imlib2->load($imgpath);
 220     }
 221
 222     my ($wd, $ht) = ($img->width, $img->height);
 223     my $max = $wd > $ht ? $wd : $ht;
 224     if ($max <= $sz) { return "$IMGURL/$path"; }
 225     my $sc = $sz/$max;
 226     my $scaled = $img->create_scaled_image($sc*$wd, $sc*$ht);
 227
 228     $scaled->image_set_format($ty->imlibfmt);
 229     $scaled->set_quality(90);
 230     my $new = "$TMP/t${$}$ext";
 231     make_path $TMP;
 232     $scaled->save($new);
 233     make_path $dir;
 234     rename $new, $thumb;
 235     return $thumburl;
 236   }
 237 }
 238
 239 ###--------------------------------------------------------------------------
 240 ### Directory listings.
 241
 242 package TrivGal::Item {
 243   sub new ($$) {
 244     my ($cls, $name) = @_;
 245     return bless { name => $name }, $cls;
 246   }
 247   sub name ($@) {
 248     my ($me, @args) = @_;
 249     return TrivGal::read_or_set $me, $me->{name}, @args;
 250   }
 251   sub comment ($@) {
 252     my ($me, @args) = @_;
 253     return TrivGal::read_or_set $me, $me->{comment}, @args;
 254   }
 255 }
 256
 257 export qw{listdir};
 258 sub listdir ($) {
 259   my ($path) = @_;
 260   my (@d, @f);
 261   my $ix = undef;
 262
 263   if (-f "$path/.tgal.index") {
 264     open my $f, "<", "$path/.tgal.index";
 265     my $item = undef;
 266     my $comment = undef;
 267     LINE: while (<$f>) {
 268       chomp;
 269       next LINE if /^\s*(\#|$)/;
 270       if (s/^\s+//) {
 271         die "no item" unless $item;
 272         $comment = defined $comment ? $comment . "\n" . $_ : $_;
 273       } else {
 274         if ($item && $comment) { $item->comment($comment); }
 275         my ($indexp, $name, $c) = /(!\s+)?(\S+)\s*(\S|\S.*\S)?\s*$/;
 276         $name = urldecode $name;
 277         my $list;
 278         if ($name =~ m!/$!) {
 279           $list = \@d;
 280           die "can't index a folder" if $indexp;
 281         } else {
 282           $list = \@f;
 283           my ($dir, $base, $ext) = TrivGal::split_path $name;
 284           die "unknown image type" unless $TYPE{lc $ext};
 285           if ($indexp) {
 286             die "two index images" if defined $ix;
 287             $ix = $item;
 288           }
 289         }
 290         $item = TrivGal::Item->new($name);
 291         $comment = $c;
 292         push @$list, $item;
 293       }
 294     }
 295     if ($item && $comment) { $item->comment($comment); }
 296     close $f;
 297   } else {
 298     my $st = stat "$path/$e";
 299     unless ($st->mode&0004) { return ([], [], undef); }
 300
 301     opendir $d, $path;
 302     my @e = readdir $d;
 303     closedir $d;
 304
 305     ENT: for my $e (sort @e) {
 306       my ($dir, $base, $ext) = split_path $e;
 307       my $dotp = $e =~ /^\./;
 308       my $st = stat "$path/$e";
 309       my $list = undef;
 310       if ($dotp) { }
 311       elsif (-d $st) { $list = \@d; }
 312       elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; }
 313       $list and push @$list, TrivGal::Item->new($e);
 314     }
 315     $ix = $f[0] if @f;
 316   }
 317
 318   return (\@d, \@f, $ix);
 319 }
 320
 321 export qw{contents};
 322 sub contents ($) {
 323   my ($file) = @_;
 324   my $contents = "";
 325   my $f;
 326   local $@;
 327   eval { open $f, "<", "$file"; };
 328   if ($@) {
 329     if ($@->isa("autodie::exception") && $@->errno == ENOENT)
 330       { return undef; }
 331     die $@;
 332   }
 333   while (sysread $f, $buf, 16384) { $contents .= $buf; }
 334   close $f;
 335   return $contents;
 336 }
 337
 338 export qw{find_covering_file};
 339 sub find_covering_file ($$$) {
 340   my ($top, $path, $name) = @_;
 341   for (;;) {
 342     my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff;
 343     if ($path eq "") { return undef; }
 344     if ($path =~ m!^(.*)/[^/]+/?!) { $path = $1; }
 345     else { $path = ""; }
 346   }
 347 }
 348
 349 ###----- That's all, folks --------------------------------------------------
 350
 351 clean_temp_files;
 352
 353 1;