| 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 | opendir $d, $path; |
| 299 | my @e = readdir $d; |
| 300 | closedir $d; |
| 301 | |
| 302 | ENT: for my $e (sort @e) { |
| 303 | my ($dir, $base, $ext) = split_path $e; |
| 304 | my $dotp = $e =~ /^\./; |
| 305 | my $st = stat "$path/$e"; |
| 306 | my $list = undef; |
| 307 | if ($dotp || !($st->mode&0004)) { } |
| 308 | elsif (-d $st) { $list = \@d; } |
| 309 | elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; } |
| 310 | $list and push @$list, TrivGal::Item->new($e); |
| 311 | } |
| 312 | $ix = $f[0] if @f; |
| 313 | } |
| 314 | |
| 315 | return (\@d, \@f, $ix); |
| 316 | } |
| 317 | |
| 318 | export qw{contents}; |
| 319 | sub contents ($) { |
| 320 | my ($file) = @_; |
| 321 | my $contents = ""; |
| 322 | my $f; |
| 323 | local $@; |
| 324 | eval { open $f, "<", "$file"; }; |
| 325 | if ($@) { |
| 326 | if ($@->isa("autodie::exception") && $@->errno == ENOENT) |
| 327 | { return undef; } |
| 328 | die $@; |
| 329 | } |
| 330 | while (sysread $f, $buf, 16384) { $contents .= $buf; } |
| 331 | close $f; |
| 332 | return $contents; |
| 333 | } |
| 334 | |
| 335 | export qw{find_covering_file}; |
| 336 | sub find_covering_file ($$$) { |
| 337 | my ($top, $path, $name) = @_; |
| 338 | for (;;) { |
| 339 | my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff; |
| 340 | if ($path eq "") { return undef; } |
| 341 | if ($path =~ m!^(.*)/[^/]+/?!) { $path = $1; } |
| 342 | else { $path = ""; } |
| 343 | } |
| 344 | } |
| 345 | |
| 346 | ###----- That's all, folks -------------------------------------------------- |
| 347 | |
| 348 | clean_temp_files; |
| 349 | |
| 350 | 1; |