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