[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::stat;
use Graphics::Magick;
use Image::ExifTool qw{};
use Image::Size qw{};
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#^ (?: (.*) /)?
		 (?: ([^/]*) \.)?
		 ([^./]*) $#x;
  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;
}

###--------------------------------------------------------------------------
### 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{$SRCURL};
our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/";

export qw{%SIZE};
our %SIZE = (smallthumb => 96,
	     medthumb => 144,
	     bigthumb => 216,
	     tiny => 320,
	     small => 480,
	     embed => 720,
	     medium => 1080,
	     big => 1600,
	     large => 2400,
	     huge => 3600,
	     vast => 5400,
	     immense => 8100);

export qw{%TYPE};
our %TYPE = map { $_ => 1 } qw{.jpg .png};

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.

my %ORIENT =
  (1 => [0, 0],
   2 => [0, 1],
   3 => [2, 0],
   4 => [2, 1],
   5 => [3, 1],
   6 => [1, 0],
   7 => [1, 1],
   8 => [3, 0]);

package TrivGal::Image {
  use File::Path qw{make_path};
  use File::stat;

  sub new ($$) {
    my ($cls, $path) = @_;
    my $imgpath = "$IMGROOT/$path";
    my $st = stat $imgpath or die "no image `$path'";
    return bless {
      path => $path, imgpath => $imgpath,
      mtime => $st->mtime,
      img => undef,
      rot => undef, flip => undef,
      wd => undef, ht => undef,
      _wd => undef, _ht => undef,
      sz => undef
    }, $cls;
  }

  sub _getsz ($) {
    my ($me) = @_;
    return if defined $me->{_wd};

    my ($wd, $ht, $err) = Image::Size::imgsize $me->{imgpath};
    defined $wd or die "failed to read size of `$me->{path}': $err";
    my $sz = $wd; if ($sz < $ht) { $sz = $ht; }
    @$me{"_wd", "_ht", "sz"} = ($wd, $ht, $sz);
  }

  sub _getexif ($) {
    my ($me) = @_;
    return if defined $me->{wd};

    $me->_getsz;
    my $exif = new Image::ExifTool; $exif->ExtractInfo($me->{imgpath});
    my $orient = $exif->GetValue("Orientation", "ValueConv");
    my ($wd, $ht) = @$me{"_wd", "_ht"};
    my ($rot, $flip);
    if (defined $orient) { ($rot, $flip) = $ORIENT{$orient}->@*; }
    else { ($rot, $flip) = (0, 0); }
    if ($rot%2) { ($wd, $ht) = ($ht, $wd); }
    @$me{"rot", "flip", "wd", "ht"} = ($rot, $flip, $wd, $ht);
  }

  sub sz ($) { my ($me) = @_; $me->_getsz; return $me->{sz}; }
  sub wd ($) { my ($me) = @_; $me->_getexif; return $me->{wd}; }
  sub ht ($) { my ($me) = @_; $me->_getexif; return $me->{ht}; }

  sub _check_gm ($) {
    my ($rc) = @_;
    "$rc" and die "failed to hack `$me->{img}': $rc";
  }

  sub scale ($$;$) {
    my ($me, $scale, $forcep) = @_;
    my $m = HTML::Mason::Request->instance;

    my $path = $me->{path};
    my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
    my $url;

    if ($me->sz <= $sz)
      { $url = $m->interp->apply_escapes("$IMGURL/$path", "u"); }
    else {
      my $tail = "scale.$sz/$path";
      my $thumb = "$CACHE/$tail";
      my $thumburl = $m->interp->apply_escapes("$CACHEURL/$tail", "u");

      my $st = stat $thumb;
      if ($st && $st->mtime > $me->{mtime})
	{ $url = $thumburl; }
      elsif (!$forcep) {
	$url =
	  $m->interp->apply_escapes("$SCRIPTURL/$path", "u") .
	  "?scale=$scale";
      } else {
	my $img = $me->{img};
	unless (defined $img) {
	  $img = $me->{img} = Graphics::Magick->new;
	  _check_gm $img->Read($me->{imgpath});
	}

	my ($dir, undef, $ext) = TrivGal::split_path $thumb;
	$img = $img->Clone;
	my $new = "$TMP/t$$-thumb$ext";
	_check_gm $img->Resize(geometry => $sz);
	make_path $TMP, { mode => 0771 };
	_check_gm $img->Write($new);
	make_path $dir, { mode => 0771 };
	rename $new, $thumb;
	$url = $thumburl;
      }
    }

    return $url;
  }
}

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

  $path =~ s#/$##;
  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 ($flags, $name, $c) =
	  /^ (?: ([-!]+) \s+)?		# flags
	     (\S+) \s*			# filename
	     (\S | \S.*\S )?		# start of the comment
	     \s*
	     $/x;
	my $indexp = $flags =~ /!/;
	my $hidep = $flags =~ /-/;
	$name = urldecode $name;
	my $list;
	$item = TrivGal::Item->new($name);
	if ($name =~ m#/$#) {
	  $list = \@d;
	  die "can't index a folder" if $indexp;
	} else {
	  $list = \@f;
	  my (undef, undef, $ext) = split_path $name;
	  die "unknown image type" unless $TYPE{lc $ext};
	  if ($indexp) {
	    die "two index images" if defined $ix;
	    $ix = $item;
	  }
	}
	$comment = $c;
	push @$list, $item unless $hidep;
      }
    }
    if ($item && $comment) { $item->comment($comment); }
    close $f;
  } else {
    my $st = stat $path;
    unless ($st->mode&0004) { return ([], [], undef); }

    opendir $d, $path;
    my @e = readdir $d;
    closedir $d;

    ENT: for my $e (sort @e) {
      my (undef, undef, $ext) = split_path $e;
      my $dotp = $e =~ /^\./;
      my $st = stat "$path/$e";
      my $list = undef;
      if ($dotp) { }
      elsif (-d $st) { $list = \@d; $e .= "/"; }
      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};
6ac5dde2	32	use File::stat;
aeca06d4	33	use Graphics::Magick;
bda837fc	34	use Image::ExifTool qw{};
8b97a4e3	35	use Image::Size qw{};
6ac5dde2 MW	36	use User::pwent;
	37	use POSIX;
	38
	39	our @EXPORT;
	40	sub export (@) { push @EXPORT, @_; }
	41
	42	###--------------------------------------------------------------------------
	43	### Internal utilities.
	44
	45	sub read_or_set ($\$@) {
	46	my ($me, $ref, @args) = @_;
	47	if (@args == 0) { return $$ref; }
	48	elsif (@args == 1) { $$ref = $args[0]; return $me; }
	49	elsif (@args > 1) { die "too many arguments"; }
	50	}
	51
	52	###--------------------------------------------------------------------------
	53	### Random utilities.
	54
	55	export qw{join_paths};
	56	sub join_paths (@) {
	57	my @p = @_;
	58	my $p = "";
	59	ELT: for my $e (@p) {
e9eac06d MW	60	$e =~ s#^/{2,}#/#;
e9eac06d MW	61	$e =~ s#([^/])/+$#$1#;
6ac5dde2	62	if ($e eq "") { next ELT; }
e9eac06d	63	elsif ($p eq "" \|\| $e =~ m#^/#) { $p = $e; }
6ac5dde2 MW	64	else { $p = "$p/$e"; }
	65	}
	66	return $p;
	67	}
	68
	69	export qw{split_path};
	70	sub split_path ($) {
	71	my ($path) = @_;
	72
9fc5e8c1 MW	73	my ($dir, $base, $ext) =
	74	$path =~ m#^ (?: (.*) /)?
	75	(?: ([^/]*) \.)?
	76	([^./]*) $#x;
6ac5dde2 MW	77	if (defined $base) { $ext = ".$ext"; }
	78	else { $base = $ext; $ext = ""; }
	79	return ($dir, $base, $ext);
	80	}
	81
	82	export qw{urlencode};
	83	sub urlencode ($) {
	84	my ($u) = @_;
e9eac06d	85	$u =~ s#([^0-9a-zA-Z_./~-])#sprintf "%%%02x", ord $1#eg;
6ac5dde2 MW	86	return $u;
	87	}
	88
	89	export qw{urldecode};
	90	sub urldecode ($) {
	91	my ($u) = @_;
e9eac06d	92	$u =~ s#\%([0-9a-fA-F]{2})#chr hex $1#eg;
6ac5dde2 MW	93	return $u;
	94	}
	95
	96	###--------------------------------------------------------------------------
6ac5dde2 MW	97	### Configuration.
	98
	99	export qw{$SCOPE $SUFFIX};
	100	our $SCOPE //= $::SCOPE;
	101	our $SUFFIX //= $::SUFFIX;
	102
	103	export qw{$IMGROOT $CACHE $TMP};
	104	our $IMGROOT //= "$ENV{HOME}/publish/$SCOPE-html$SUFFIX/tgal-images";
	105	our $CACHE //=
	106	($ENV{XDG_CACHE_HOME} // "$ENV{HOME}/.cache") .
	107	"/tgal/$SCOPE$SUFFIX";
	108	our $TMP //= "$CACHE/tmp";
	109
	110	export qw{$ROOTURL $IMGURL $CACHEURL $STATICURL $SCRIPTURL};
	111	my $user = getpwuid($>)->name;
	112	our $ROOTURL //= "/~$user";
	113	our $IMGURL //= "$ROOTURL/tgal-images";
	114	our $CACHEURL //= "$ROOTURL/tgal-cache";
	115	our $STATICURL //= "$ROOTURL/tgal-static";
	116	our $SCRIPTURL;
	117
a38a867d MW	118	export qw{$SRCURL};
	119	our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/";
	120
6ac5dde2	121	export qw{%SIZE};
1408b7a2 MW	122	our %SIZE = (smallthumb => 96,
1408b7a2 MW	123	medthumb => 144,
3de03c7a MW	124	bigthumb => 216,
3de03c7a MW	125	tiny => 320,
40c686c2 MW	126	small => 480,
40c686c2 MW	127	embed => 720,
3de03c7a MW	128	medium => 1080,
	129	big => 1600,
	130	large => 2400,
	131	huge => 3600,
	132	vast => 5400,
	133	immense => 8100);
6ac5dde2	134
e9f8c99e MW	135	export qw{%TYPE};
	136	our %TYPE = map { $_ => 1 } qw{.jpg .png};
	137
6ac5dde2 MW	138	export qw{init};
	139	my $initp = 0;
	140	sub init () {
	141	my $m = HTML::Mason::Request->instance;
	142	my $r = $m->cgi_request;
	143
	144	$m->interp->set_escape(u => sub { my ($r) = @_; $$r = urlencode $$r; });
	145
	146	return unless !$initp;
	147
	148	$SCRIPTURL //= $r->subprocess_env("SCRIPT_NAME");
	149	$initp = 1;
	150	}
	151
	152	###--------------------------------------------------------------------------
	153	### Temporary files.
	154
	155	export qw{clean_temp_files};
	156	sub clean_temp_files () {
	157	my $d;
	158
	159	eval { opendir $d, $TMP; };
	160	if ($@) {
	161	if ($@->isa("autodie::exception") && $@->errno == ENOENT) { return; }
	162	else { die $@; }
	163	}
	164	my $now = time;
	165	FILE: while (my $name = readdir $d) {
	166	next FILE unless $name =~ /^t(\d+)\-/;
	167	my $pid = $1;
	168	next FILE if kill 0, $pid;
	169	my $f = "$TMP/$name";
	170	my $st = stat $name;
	171	next FILE if $now - $st->mtime() < 300;
	172	unlink $f;
	173	}
	174	closedir $d;
	175	}
	176
	177	###--------------------------------------------------------------------------
	178	### Scaled images.
	179
bda837fc MW	180	my %ORIENT =
	181	(1 => [0, 0],
	182	2 => [0, 1],
	183	3 => [2, 0],
	184	4 => [2, 1],
	185	5 => [3, 1],
	186	6 => [1, 0],
	187	7 => [1, 1],
	188	8 => [3, 0]);
	189
4e74ddf4 MW	190	package TrivGal::Image {
	191	use File::Path qw{make_path};
	192	use File::stat;
	193
	194	sub new ($$) {
	195	my ($cls, $path) = @_;
	196	my $imgpath = "$IMGROOT/$path";
	197	my $st = stat $imgpath or die "no image `$path'";
	198	return bless {
4fcd273f	199	path => $path, imgpath => $imgpath,
4e74ddf4	200	mtime => $st->mtime,
8b97a4e3	201	img => undef,
5d6997b3 MW	202	rot => undef, flip => undef,
5d6997b3 MW	203	wd => undef, ht => undef,
8b97a4e3 MW	204	_wd => undef, _ht => undef,
8b97a4e3 MW	205	sz => undef
4e74ddf4 MW	206	}, $cls;
	207	}
	208
8b97a4e3 MW	209	sub _getsz ($) {
	210	my ($me) = @_;
	211	return if defined $me->{_wd};
	212
	213	my ($wd, $ht, $err) = Image::Size::imgsize $me->{imgpath};
	214	defined $wd or die "failed to read size of `$me->{path}': $err";
	215	my $sz = $wd; if ($sz < $ht) { $sz = $ht; }
	216	@$me{"_wd", "_ht", "sz"} = ($wd, $ht, $sz);
	217	}
	218
5d6997b3 MW	219	sub _getexif ($) {
	220	my ($me) = @_;
	221	return if defined $me->{wd};
	222
	223	$me->_getsz;
	224	my $exif = new Image::ExifTool; $exif->ExtractInfo($me->{imgpath});
	225	my $orient = $exif->GetValue("Orientation", "ValueConv");
	226	my ($wd, $ht) = @$me{"_wd", "_ht"};
	227	my ($rot, $flip);
	228	if (defined $orient) { ($rot, $flip) = $ORIENT{$orient}->@*; }
	229	else { ($rot, $flip) = (0, 0); }
	230	if ($rot%2) { ($wd, $ht) = ($ht, $wd); }
	231	@$me{"rot", "flip", "wd", "ht"} = ($rot, $flip, $wd, $ht);
	232	}
	233
8b97a4e3	234	sub sz ($) { my ($me) = @_; $me->_getsz; return $me->{sz}; }
5d6997b3 MW	235	sub wd ($) { my ($me) = @_; $me->_getexif; return $me->{wd}; }
5d6997b3 MW	236	sub ht ($) { my ($me) = @_; $me->_getexif; return $me->{ht}; }
8b97a4e3	237
aeca06d4 MW	238	sub _check_gm ($) {
	239	my ($rc) = @_;
	240	"$rc" and die "failed to hack `$me->{img}': $rc";
	241	}
	242
784bdf8f MW	243	sub scale ($$;$) {
784bdf8f MW	244	my ($me, $scale, $forcep) = @_;
1b3d6791	245	my $m = HTML::Mason::Request->instance;
4e74ddf4 MW	246
	247	my $path = $me->{path};
	248	my $sz = $SIZE{$scale} or die "unknown scale `$scale'";
351bb9a6 MW	249	my $url;
351bb9a6 MW	250
373818eb	251	if ($me->sz <= $sz)
351bb9a6 MW	252	{ $url = $m->interp->apply_escapes("$IMGURL/$path", "u"); }
	253	else {
	254	my $tail = "scale.$sz/$path";
	255	my $thumb = "$CACHE/$tail";
	256	my $thumburl = $m->interp->apply_escapes("$CACHEURL/$tail", "u");
	257
	258	my $st = stat $thumb;
	259	if ($st && $st->mtime > $me->{mtime})
	260	{ $url = $thumburl; }
	261	elsif (!$forcep) {
	262	$url =
	263	$m->interp->apply_escapes("$SCRIPTURL/$path", "u") .
	264	"?scale=$scale";
	265	} else {
351bb9a6 MW	266	my $img = $me->{img};
351bb9a6 MW	267	unless (defined $img) {
aeca06d4 MW	268	$img = $me->{img} = Graphics::Magick->new;
aeca06d4 MW	269	_check_gm $img->Read($me->{imgpath});
351bb9a6 MW	270	}
351bb9a6 MW	271
603ed7ab	272	my ($dir, undef, $ext) = TrivGal::split_path $thumb;
aeca06d4 MW	273	$img = $img->Clone;
	274	my $new = "$TMP/t$$-thumb$ext";
	275	_check_gm $img->Resize(geometry => $sz);
351bb9a6	276	make_path $TMP, { mode => 0771 };
aeca06d4	277	_check_gm $img->Write($new);
351bb9a6 MW	278	make_path $dir, { mode => 0771 };
	279	rename $new, $thumb;
	280	$url = $thumburl;
bda837fc	281	}
4e74ddf4 MW	282	}
4e74ddf4 MW	283
351bb9a6	284	return $url;
4e74ddf4	285	}
6ac5dde2 MW	286	}
	287
	288	###--------------------------------------------------------------------------
	289	### Directory listings.
	290
	291	package TrivGal::Item {
	292	sub new ($$) {
	293	my ($cls, $name) = @_;
	294	return bless { name => $name }, $cls;
	295	}
	296	sub name ($@) {
	297	my ($me, @args) = @_;
	298	return TrivGal::read_or_set $me, $me->{name}, @args;
	299	}
	300	sub comment ($@) {
	301	my ($me, @args) = @_;
	302	return TrivGal::read_or_set $me, $me->{comment}, @args;
	303	}
65e4ebfd	304	}
6ac5dde2 MW	305
	306	export qw{listdir};
	307	sub listdir ($) {
	308	my ($path) = @_;
	309	my (@d, @f);
	310	my $ix = undef;
	311
24f4eac3	312	$path =~ s#/$##;
6ac5dde2 MW	313	if (-f "$path/.tgal.index") {
	314	open my $f, "<", "$path/.tgal.index";
	315	my $item = undef;
	316	my $comment = undef;
	317	LINE: while (<$f>) {
	318	chomp;
	319	next LINE if /^\s*(\#\|$)/;
	320	if (s/^\s+//) {
	321	die "no item" unless $item;
	322	$comment = defined $comment ? $comment . "\n" . $_ : $_;
	323	} else {
	324	if ($item && $comment) { $item->comment($comment); }
9940cc5a	325	my ($flags, $name, $c) =
6e51720c	326	/^ (?: ([-!]+) \s+)? # flags
9fc5e8c1 MW	327	(\S+) \s* # filename
	328	(\S \| \S.*\S )? # start of the comment
	329	\s*
	330	$/x;
9940cc5a	331	my $indexp = $flags =~ /!/;
6e51720c	332	my $hidep = $flags =~ /-/;
6ac5dde2 MW	333	$name = urldecode $name;
6ac5dde2 MW	334	my $list;
0485371e	335	$item = TrivGal::Item->new($name);
e9eac06d	336	if ($name =~ m#/$#) {
6ac5dde2 MW	337	$list = \@d;
	338	die "can't index a folder" if $indexp;
	339	} else {
	340	$list = \@f;
d8ab1dea	341	my (undef, undef, $ext) = split_path $name;
6ac5dde2 MW	342	die "unknown image type" unless $TYPE{lc $ext};
	343	if ($indexp) {
	344	die "two index images" if defined $ix;
	345	$ix = $item;
	346	}
	347	}
6ac5dde2	348	$comment = $c;
6e51720c	349	push @$list, $item unless $hidep;
6ac5dde2 MW	350	}
	351	}
	352	if ($item && $comment) { $item->comment($comment); }
	353	close $f;
	354	} else {
ebe19115	355	my $st = stat $path;
32fc7001 MW	356	unless ($st->mode&0004) { return ([], [], undef); }
32fc7001 MW	357
6ac5dde2 MW	358	opendir $d, $path;
	359	my @e = readdir $d;
	360	closedir $d;
	361
	362	ENT: for my $e (sort @e) {
d8ab1dea	363	my (undef, undef, $ext) = split_path $e;
6ac5dde2 MW	364	my $dotp = $e =~ /^\./;
	365	my $st = stat "$path/$e";
	366	my $list = undef;
32fc7001	367	if ($dotp) { }
24f4eac3	368	elsif (-d $st) { $list = \@d; $e .= "/"; }
6ac5dde2 MW	369	elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; }
	370	$list and push @$list, TrivGal::Item->new($e);
	371	}
	372	$ix = $f[0] if @f;
	373	}
	374
	375	return (\@d, \@f, $ix);
	376	}
	377
	378	export qw{contents};
	379	sub contents ($) {
	380	my ($file) = @_;
	381	my $contents = "";
	382	my $f;
	383	local $@;
	384	eval { open $f, "<", "$file"; };
	385	if ($@) {
	386	if ($@->isa("autodie::exception") && $@->errno == ENOENT)
	387	{ return undef; }
	388	die $@;
	389	}
	390	while (sysread $f, $buf, 16384) { $contents .= $buf; }
	391	close $f;
	392	return $contents;
	393	}
	394
	395	export qw{find_covering_file};
	396	sub find_covering_file ($$$) {
	397	my ($top, $path, $name) = @_;
	398	for (;;) {
	399	my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff;
	400	if ($path eq "") { return undef; }
e9eac06d	401	if ($path =~ m#^(.*)/[^/]+/?#) { $path = $1; }
6ac5dde2 MW	402	else { $path = ""; }
	403	}
	404	}
	405
	406	###----- That's all, folks --------------------------------------------------
	407
	408	clean_temp_files;
	409
	410	1;