[tgal] / mason / .perl-lib / TrivGal.pm

### -*-cperl-*-
###
### Main output for Trivial Gallery.
###
### (c) 2021 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This file is part of Trivial Gallery.
###
### Trivial Gallery is free software: you can redistribute it and/or modify
### it under the terms of the GNU Affero General Public License as
### published by the Free Software Foundation; either version 3 of the
### License, or (at your option) any later version.
###
### Trivial Gallery is distributed in the hope that it will be useful, but
### WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
### Affero General Public License for more details.
###
### You should have received a copy of the GNU Affero General Public
### License along with Trivial Gallery.  If not, see
### <https://www.gnu.org/licenses/>.

package TrivGal;

use autodie qw{:all};

use Errno;
use Exporter qw{import};
use File::Path qw{make_path};
use File::stat;
use Image::Imlib2;
use User::pwent;
use POSIX;

our @EXPORT;
sub export (@) { push @EXPORT, @_; }

###--------------------------------------------------------------------------
### Internal utilities.

sub read_or_set ($\$@) {
  my ($me, $ref, @args) = @_;
  if (@args == 0) { return $$ref; }
  elsif (@args == 1) { $$ref = $args[0]; return $me; }
  elsif (@args > 1) { die "too many arguments"; }
}

###--------------------------------------------------------------------------
### Random utilities.

export qw{join_paths};
sub join_paths (@) {
  my @p = @_;
  my $p = "";
  ELT: for my $e (@p) {
    $e =~ s:^/{2,}:/:;
    $e =~ s,([^/])/+$,$1,;
    if ($e eq "") { next ELT; }
    elsif ($p eq "" || $e =~ m,^/,) { $p = $e; }
    else { $p = "$p/$e"; }
  }
  return $p;
}

export qw{split_path};
sub split_path ($) {
  my ($path) = @_;

  my ($dir, $base, $ext) = $path =~ m,^(?:(.*)/)?(?:([^/]*)\.)?([^./]*)$,;
  if (defined $base) { $ext = ".$ext"; }
  else { $base = $ext; $ext = ""; }
  return ($dir, $base, $ext);
}

export qw{urlencode};
sub urlencode ($) {
  my ($u) = @_;
  $u =~ s:([^0-9a-zA-Z_./~-]):sprintf "%%%02x", ord $1:eg;
  return $u;
}

export qw{urldecode};
sub urldecode ($) {
  my ($u) = @_;
  $u =~ s:\%([0-9a-fA-F]{2}):chr hex $1:eg;
  return $u;
}

###--------------------------------------------------------------------------
### Image types.

our %TYPE;

package TrivGal::ImageType {
  sub new ($$) {
    my ($cls, $ext) = @_;
    return $TYPE{$ext} = bless { ext => $ext }, $cls;
  }
  sub ext ($) {
    my ($me, @args) = @_;
    return $me->{ext};
  }
  sub mimetype ($@) {
    my ($me, @args) = @_;
    return TrivGal::read_or_set $me, $me->{mimetype}, @args;
  }
  sub imlibfmt ($@) {
    my ($me, @args) = @_;
    return TrivGal::read_or_set $me, $me->{imlibfmt}, @args;
  }
}

TrivGal::ImageType->new(".jpg")->mimetype("image/jpeg")->imlibfmt("jpeg");
TrivGal::ImageType->new(".png")->mimetype("image/png")->imlibfmt("png");

###--------------------------------------------------------------------------
### Configuration.

export qw{$SCOPE $SUFFIX};
our $SCOPE //= $::SCOPE;
our $SUFFIX //= $::SUFFIX;

export qw{$IMGROOT $CACHE $TMP};
our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
our $CACHE //=
  ($ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache") .
  "/tgal/$SCOPE$SUFFIX";
our $TMP //= "$CACHE/tmp";

export qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
my $user = getpwuid($>)->name;
our $ROOTURL //= "/~$user";
our $IMGURL //= "$ROOTURL/tgal-images";
our $CACHEURL //= "$ROOTURL/tgal-cache";
our $STATICURL //= "$ROOTURL/tgal-static";
our $SCRIPTURL;

export qw{%SIZE};
our %SIZE = (thumb => 228, view => 1200);

export qw{init};
my $initp = 0;
sub init () {
  my $m = HTML::Mason::Request->instance;
  my $r = $m->cgi_request;

  $m->interp->set_escape(u => sub { my ($r) = @_; $$r = urlencode $$r; });

  return unless !$initp;

  $SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
  $initp = 1;
}

###--------------------------------------------------------------------------
### Temporary files.

export qw{clean_temp_files};
sub clean_temp_files () {
  my $d;

  eval { opendir $d, $TMP; };
  if ($@) {
    if ($@->isa("autodie::exception") && $@->errno == ENOENT) { return; }
    else { die $@; }
  }
  my $now = time;
  FILE: while (my $name = readdir $d) {
    next FILE unless $name =~ /^t(\d+)\-/;
    my $pid = $1;
    next FILE if kill 0, $pid;
    my $f = "$TMP/$name";
    my $st = stat $name;
    next FILE if $now - $st->mtime() < 300;
    unlink $f;
  }
  closedir $d;
}

###--------------------------------------------------------------------------
### Scaled images.

export qw{scaled};
sub scaled ($$) {
  my ($scale, $path) = @_;

  my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
  my $imgpath = "$IMGROOT/$path";
  my $ist = stat $imgpath or die "no image `$path'";
  my $thumb = "$CACHE/scaled.$scale/$path";
  my $thumburl = "$CACHEURL/scaled.$scale/$path";
  my $tst = stat $thumb;
  if (defined $tst && $tst->mtime > $ist->mtime) { return $thumburl; }
  my ($dir, $base, $ext) = split_path $thumb;
  my $ty = $TYPE{lc $ext} or die "unknown type `$ext'";

  my $img = Image::Imlib2->load($imgpath);
  my ($wd, $ht) = ($img->width, $img->height);
  my $max = $wd > $ht ? $wd : $ht;
  if ($max <= $sz) { return "$IMGURL/$path"; }
  my $sc = $sz/$max;
  my $scaled = $img->create_scaled_image($sc*$wd, $sc*$ht);

  $scaled->image_set_format($ty->imlibfmt);
  $scaled->set_quality(90);
  my $new = "$TMP/t${$}$ext";
  make_path $TMP;
  $scaled->save($new);
  make_path $dir;
  rename $new, $thumb;
  return $thumburl;
}

###--------------------------------------------------------------------------
### Directory listings.

package TrivGal::Item {
  sub new ($$) {
    my ($cls, $name) = @_;
    return bless { name => $name }, $cls;
  }
  sub name ($@) {
    my ($me, @args) = @_;
    return TrivGal::read_or_set $me, $me->{name}, @args;
  }
  sub comment ($@) {
    my ($me, @args) = @_;
    return TrivGal::read_or_set $me, $me->{comment}, @args;
  }
}

export qw{listdir};
sub listdir ($) {
  my ($path) = @_;
  my (@d, @f);
  my $ix = undef;

  if (-f "$path/.tgal.index") {
    open my $f, "<", "$path/.tgal.index";
    my $item = undef;
    my $comment = undef;
    LINE: while (<$f>) {
      chomp;
      next LINE if /^\s*(\#|$)/;
      if (s/^\s+//) {
	die "no item" unless $item;
	$comment = defined $comment ? $comment . "\n" . $_ : $_;
      } else {
	if ($item && $comment) { $item->comment($comment); }
	my ($indexp, $name, $c) = /(!\s+)?(\S+)\s*(\S|\S.*\S)?\s*$/;
	$name = urldecode $name;
	my $list;
	if ($name =~ m!/$!) {
	  $list = \@d;
	  die "can't index a folder" if $indexp;
	} else {
	  $list = \@f;
	  my ($dir, $base, $ext) = TrivGal::split_path $name;
	  die "unknown image type" unless $TYPE{lc $ext};
	  if ($indexp) {
	    die "two index images" if defined $ix;
	    $ix = $item;
	  }
	}
	$item = TrivGal::Item->new($name);
	$comment = $c;
	push @$list, $item;
      }
    }
    if ($item && $comment) { $item->comment($comment); }
    close $f;
  } else {
    opendir $d, $path;
    my @e = readdir $d;
    closedir $d;

    ENT: for my $e (sort @e) {
      my ($dir, $base, $ext) = split_path $e;
      my $dotp = $e =~ /^\./;
      my $st = stat "$path/$e";
      my $list = undef;
      if ($dotp || !($st->mode&0004)) { }
      elsif (-d $st) { $list = \@d; }
      elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; }
      $list and push @$list, TrivGal::Item->new($e);
    }
    $ix = $f[0] if @f;
  }

  return (\@d, \@f, $ix);
}

export qw{contents};
sub contents ($) {
  my ($file) = @_;
  my $contents = "";
  my $f;
  local $@;
  eval { open $f, "<", "$file"; };
  if ($@) {
    if ($@->isa("autodie::exception") && $@->errno == ENOENT)
      { return undef; }
    die $@;
  }
  while (sysread $f, $buf, 16384) { $contents .= $buf; }
  close $f;
  return $contents;
}

export qw{find_covering_file};
sub find_covering_file ($$$) {
  my ($top, $path, $name) = @_;
  for (;;) {
    my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff;
    if ($path eq "") { return undef; }
    if ($path =~ m!^(.*)/[^/]+/?!) { $path = $1; }
    else { $path = ""; }
  }
}

###----- That's all, folks --------------------------------------------------

clean_temp_files;

1;
Commit	Line	Data
6ac5dde2 MW	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	}
65e4ebfd	114	}
6ac5dde2 MW	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 = (thumb => 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	}
65e4ebfd	233	}
6ac5dde2 MW	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;