3 ### Main output for Trivial Gallery.
5 ### (c) 2021 Mark Wooding
8 ###----- Licensing notice ---------------------------------------------------
10 ### This file is part of Trivial Gallery.
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.
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.
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/>.
31 use Exporter
qw{import
};
33 use Image
::ExifTool
qw{};
39 sub export
(@
) { push @EXPORT, @_; }
41 ###--------------------------------------------------------------------------
42 ### Internal utilities.
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"; }
51 ###--------------------------------------------------------------------------
54 export
qw{join_paths
};
60 $e =~ s
#([^/])/+$#$1#;
61 if ($e eq "") { next ELT
; }
62 elsif ($p eq "" || $e =~ m
#^/#) { $p = $e; }
63 else { $p = "$p/$e"; }
68 export
qw{split_path
};
72 my ($dir, $base, $ext) =
73 $path =~ m
#^ (?: (.*) /)?
76 if (defined $base) { $ext = ".$ext"; }
77 else { $base = $ext; $ext = ""; }
78 return ($dir, $base, $ext);
84 $u =~ s
#([^0-9a-zA-Z_./~-])#sprintf "%%%02x", ord $1#eg;
91 $u =~ s
#\%([0-9a-fA-F]{2})#chr hex $1#eg;
95 ###--------------------------------------------------------------------------
100 package TrivGal
::ImageType
{
102 my ($cls, $ext) = @_;
103 return $TYPE{$ext} = bless { ext
=> $ext }, $cls;
106 my ($me, @args) = @_;
110 my ($me, @args) = @_;
111 return TrivGal
::read_or_set
$me, $me->{mimetype
}, @args;
114 my ($me, @args) = @_;
115 return TrivGal
::read_or_set
$me, $me->{imlibfmt
}, @args;
119 TrivGal
::ImageType
->new(".jpg")->mimetype("image/jpeg")->imlibfmt("jpeg");
120 TrivGal
::ImageType
->new(".png")->mimetype("image/png")->imlibfmt("png");
122 ###--------------------------------------------------------------------------
125 export
qw{$SCOPE $SUFFIX};
126 our $SCOPE //= $::SCOPE
;
127 our $SUFFIX //= $::SUFFIX
;
129 export
qw{$IMGROOT $CACHE $TMP};
130 our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
132 ($ENV{XDG_CACHE_HOME
} // "$ENV{HOME}/.cache") .
133 "/tgal/$SCOPE$SUFFIX";
134 our $TMP //= "$CACHE/tmp";
136 export
qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
137 my $user = getpwuid($>)->name;
138 our $ROOTURL //= "/~$user";
139 our $IMGURL //= "$ROOTURL/tgal-images";
140 our $CACHEURL //= "$ROOTURL/tgal-cache";
141 our $STATICURL //= "$ROOTURL/tgal-static";
145 our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/";
148 our %SIZE = (smallthumb
=> 96,
156 my $m = HTML
::Mason
::Request
->instance;
157 my $r = $m->cgi_request;
159 $m->interp->set_escape(u
=> sub { my ($r) = @_; $$r = urlencode
$$r; });
161 return unless !$initp;
163 $SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
167 ###--------------------------------------------------------------------------
170 export
qw{clean_temp_files
};
171 sub clean_temp_files
() {
174 eval { opendir $d, $TMP; };
176 if ($@
->isa("autodie::exception") && $@
->errno == ENOENT
) { return; }
180 FILE
: while (my $name = readdir $d) {
181 next FILE
unless $name =~ /^t(\d+)\-/;
183 next FILE
if kill 0, $pid;
184 my $f = "$TMP/$name";
186 next FILE
if $now - $st->mtime() < 300;
192 ###--------------------------------------------------------------------------
205 package TrivGal
::Image
{
206 use File
::Path
qw{make_path
};
210 my ($cls, $path) = @_;
211 my $imgpath = "$IMGROOT/$path";
212 my $st = stat $imgpath or die "no image `$path'";
221 my ($me, $scale, $forcep) = @_;
222 my $m = HTML
::Mason
::Request
->instance;
224 my $path = $me->{path
};
225 my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
226 my $thumb = "$CACHE/scale.$sz/$path";
228 $m->interp->apply_escapes("$CACHEURL/scale.$sz/$path", "u");
229 my $st = stat $thumb;
230 if (defined $st && $st->mtime > $me->{mtime
}) { return $thumburl; }
232 $m->interp->apply_escapes("$SCRIPTURL/$path", "u") . "?scale=$scale"
235 my ($dir, $base, $ext) = TrivGal
::split_path
$thumb;
236 my $ty = $TYPE{lc $ext} or die "unknown type `$ext'";
238 my $img = $me->{img
};
239 unless (defined $img) {
240 my $imgpath = "$IMGROOT/$path";
241 my $exif = new Image
::ExifTool
;
242 $exif->ExtractInfo($imgpath);
243 my $orient = $exif->GetValue("Orientation", "ValueConv");
244 $img = $me->{img
} = Image
::Imlib2
->load($imgpath);
245 if (defined $orient) {
246 my ($rot, $flip) = @
{$ORIENT{$orient}};
247 if ($rot) { $img->image_orientate($rot); }
248 if ($flip) { $img->flip_horizontal(); }
252 my ($wd, $ht) = ($img->width, $img->height);
253 my $max = $wd > $ht ?
$wd : $ht;
254 if ($max <= $sz) { return "$IMGURL/$path"; }
256 my $scaled = $img->create_scaled_image($sc*$wd, $sc*$ht);
258 $scaled->image_set_format($ty->imlibfmt);
259 $scaled->set_quality(90);
260 my $new = "$TMP/t$$-$ext";
269 ###--------------------------------------------------------------------------
270 ### Directory listings.
272 package TrivGal
::Item
{
274 my ($cls, $name) = @_;
275 return bless { name
=> $name }, $cls;
278 my ($me, @args) = @_;
279 return TrivGal
::read_or_set
$me, $me->{name
}, @args;
282 my ($me, @args) = @_;
283 return TrivGal
::read_or_set
$me, $me->{comment
}, @args;
294 if (-f
"$path/.tgal.index") {
295 open my $f, "<", "$path/.tgal.index";
300 next LINE
if /^\s*(\#|$)/;
302 die "no item" unless $item;
303 $comment = defined $comment ?
$comment . "\n" . $_ : $_;
305 if ($item && $comment) { $item->comment($comment); }
306 my ($indexp, $name, $c) =
307 /^ (! \s
+)?
# index flag
309 (\S
| \S
.*\S
)?
# start of the comment
312 $name = urldecode
$name;
314 $item = TrivGal
::Item
->new($name);
315 if ($name =~ m
#/$#) {
317 die "can't index a folder" if $indexp;
320 my ($dir, $base, $ext) = split_path
$name;
321 die "unknown image type" unless $TYPE{lc $ext};
323 die "two index images" if defined $ix;
331 if ($item && $comment) { $item->comment($comment); }
335 unless ($st->mode&0004) { return ([], [], undef); }
341 ENT
: for my $e (sort @e) {
342 my ($dir, $base, $ext) = split_path
$e;
343 my $dotp = $e =~ /^\./;
344 my $st = stat "$path/$e";
347 elsif (-d
$st) { $list = \
@d; $e .= "/"; }
348 elsif ($TYPE{lc $ext} && -f
$st) { $list = \
@f; }
349 $list and push @
$list, TrivGal
::Item
->new($e);
354 return (\
@d, \
@f, $ix);
363 eval { open $f, "<", "$file"; };
365 if ($@
->isa("autodie::exception") && $@
->errno == ENOENT
)
369 while (sysread $f, $buf, 16384) { $contents .= $buf; }
374 export
qw{find_covering_file
};
375 sub find_covering_file
($$$) {
376 my ($top, $path, $name) = @_;
378 my $stuff = contents
"$top/$path/$name"; return $stuff if defined $stuff;
379 if ($path eq "") { return undef; }
380 if ($path =~ m
#^(.*)/[^/]+/?#) { $path = $1; }
385 ###----- That's all, folks --------------------------------------------------