| 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; |