X-Git-Url: https://git.distorted.org.uk/~mdw/tgal/blobdiff_plain/f615860793ef624269d888e88385647c73043938..3de03c7ad617d0f03c062a82a5bb5eb070f0f7cd:/mason/.perl-lib/TrivGal.pm diff --git a/mason/.perl-lib/TrivGal.pm b/mason/.perl-lib/TrivGal.pm index ea3b47a..4e5527b 100644 --- a/mason/.perl-lib/TrivGal.pm +++ b/mason/.perl-lib/TrivGal.pm @@ -32,6 +32,7 @@ use Exporter qw{import}; use File::stat; use Image::ExifTool qw{}; use Image::Imlib2; +use Image::Size qw{}; use User::pwent; use POSIX; @@ -56,10 +57,10 @@ sub join_paths (@) { my @p = @_; my $p = ""; ELT: for my $e (@p) { - $e =~ s:^/{2,}:/:; - $e =~ s,([^/])/+$,$1,; + $e =~ s#^/{2,}#/#; + $e =~ s#([^/])/+$#$1#; if ($e eq "") { next ELT; } - elsif ($p eq "" || $e =~ m,^/,) { $p = $e; } + elsif ($p eq "" || $e =~ m#^/#) { $p = $e; } else { $p = "$p/$e"; } } return $p; @@ -69,7 +70,10 @@ export qw{split_path}; sub split_path ($) { my ($path) = @_; - my ($dir, $base, $ext) = $path =~ m,^(?:(.*)/)?(?:([^/]*)\.)?([^./]*)$,; + my ($dir, $base, $ext) = + $path =~ m#^ (?: (.*) /)? + (?: ([^/]*) \.)? + ([^./]*) $#x; if (defined $base) { $ext = ".$ext"; } else { $base = $ext; $ext = ""; } return ($dir, $base, $ext); @@ -78,14 +82,14 @@ sub split_path ($) { export qw{urlencode}; sub urlencode ($) { my ($u) = @_; - $u =~ s:([^0-9a-zA-Z_./~-]):sprintf "%%%02x", ord $1:eg; + $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; + $u =~ s#\%([0-9a-fA-F]{2})#chr hex $1#eg; return $u; } @@ -144,8 +148,16 @@ our $SRCURL = "https://git.distorted.org.uk/~mdw/tgal/"; export qw{%SIZE}; our %SIZE = (smallthumb => 96, medthumb => 144, - bigthumb => 228, - view => 1200); + bigthumb => 216, + tiny => 320, + small => 480, + embed => 720, + medium => 1080, + big => 1600, + large => 2400, + huge => 3600, + vast => 5400, + immense => 8100); export qw{init}; my $initp = 0; @@ -208,53 +220,93 @@ package TrivGal::Image { my $imgpath = "$IMGROOT/$path"; my $st = stat $imgpath or die "no image `$path'"; return bless { - path => $path, + path => $path, imgpath => $imgpath, mtime => $st->mtime, - img => undef + img => undef, + rot => undef, flip => undef, + wd => undef, ht => undef, + _wd => undef, _ht => undef, + sz => undef }, $cls; } - sub scale ($$) { - my ($me, $scale) = @_; + 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 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 $thumb = "$CACHE/scale.$sz/$path"; - my $thumburl = "$CACHEURL/scale.$sz/$path"; - my $st = stat $thumb; - if (defined $st && $st->mtime > $me->{mtime}) { return $thumburl; } - - my ($dir, $base, $ext) = TrivGal::split_path $thumb; - my $ty = $TYPE{lc $ext} or die "unknown type `$ext'"; - - my $img = $me->{img}; - unless (defined $img) { - my $imgpath = "$IMGROOT/$path"; - my $exif = new Image::ExifTool; - $exif->ExtractInfo($imgpath); - my $orient = $exif->GetValue("Orientation", "ValueConv"); - $img = $me->{img} = Image::Imlib2->load($imgpath); - if (defined $orient) { - my ($rot, $flip) = @{$ORIENT{$orient}}; - if ($rot) { $img->image_orientate($rot); } - if ($flip) { $img->flip_horizontal(); } + 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) { + $me->_getexif; + $img = $me->{img} = Image::Imlib2->load($me->{imgpath}); + if ($me->{rot}) { $img->image_orientate($me->{rot}); } + if ($me->{flip}) { $img->flip_horizontal(); } + } + + my ($dir, undef, $ext) = TrivGal::split_path $thumb; + my $ty = $TYPE{lc $ext} or die "unknown type `$ext'"; + my $sc = $sz/$me->sz; + 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, { mode => 0771 }; + $scaled->save($new); + make_path $dir, { mode => 0771 }; + rename $new, $thumb; + $url = $thumburl; } } - 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; + return $url; } } @@ -282,6 +334,7 @@ sub listdir ($) { my (@d, @f); my $ix = undef; + $path =~ s#/$##; if (-f "$path/.tgal.index") { open my $f, "<", "$path/.tgal.index"; my $item = undef; @@ -294,30 +347,37 @@ sub listdir ($) { $comment = defined $comment ? $comment . "\n" . $_ : $_; } else { if ($item && $comment) { $item->comment($comment); } - my ($indexp, $name, $c) = /(!\s+)?(\S+)\s*(\S|\S.*\S)?\s*$/; + 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; - if ($name =~ m!/$!) { + $item = TrivGal::Item->new($name); + if ($name =~ m#/$#) { $list = \@d; die "can't index a folder" if $indexp; } else { $list = \@f; - my ($dir, $base, $ext) = TrivGal::split_path $name; + 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; } } - $item = TrivGal::Item->new($name); $comment = $c; - push @$list, $item; + push @$list, $item unless $hidep; } } if ($item && $comment) { $item->comment($comment); } close $f; } else { - my $st = stat "$path/$e"; + my $st = stat $path; unless ($st->mode&0004) { return ([], [], undef); } opendir $d, $path; @@ -325,12 +385,12 @@ sub listdir ($) { closedir $d; ENT: for my $e (sort @e) { - my ($dir, $base, $ext) = split_path $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; } + elsif (-d $st) { $list = \@d; $e .= "/"; } elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; } $list and push @$list, TrivGal::Item->new($e); } @@ -363,7 +423,7 @@ sub find_covering_file ($$$) { for (;;) { my $stuff = contents "$top/$path/$name"; return $stuff if defined $stuff; if ($path eq "") { return undef; } - if ($path =~ m!^(.*)/[^/]+/?!) { $path = $1; } + if ($path =~ m#^(.*)/[^/]+/?#) { $path = $1; } else { $path = ""; } } }