X-Git-Url: https://git.distorted.org.uk/~mdw/tgal/blobdiff_plain/dfdd19641b4eba66aefedb9c1a7ce4f93d74b347..5d6997b3e9eab746f09b04f899952a6aab68ab80:/mason/.perl-lib/TrivGal.pm diff --git a/mason/.perl-lib/TrivGal.pm b/mason/.perl-lib/TrivGal.pm index 9822a0b..3346c1a 100644 --- a/mason/.perl-lib/TrivGal.pm +++ b/mason/.perl-lib/TrivGal.pm @@ -29,9 +29,10 @@ use autodie qw{:all}; use Errno; use Exporter qw{import}; -use File::Path qw{make_path}; 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; } @@ -138,8 +142,16 @@ 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 = (bigthumb => 228, view => 1200); +our %SIZE = (smallthumb => 96, + medthumb => 144, + bigthumb => 228, + small => 480, + embed => 720, + view => 1200); export qw{init}; my $initp = 0; @@ -183,35 +195,113 @@ sub clean_temp_files () { ###-------------------------------------------------------------------------- ### 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; +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 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) { + $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; + } + } + + return $url; + } } ###-------------------------------------------------------------------------- @@ -238,6 +328,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; @@ -250,40 +341,50 @@ 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; + unless ($st->mode&0004) { return ([], [], undef); } + opendir $d, $path; my @e = readdir $d; 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 || !($st->mode&0004)) { } - elsif (-d $st) { $list = \@d; } + if ($dotp) { } + elsif (-d $st) { $list = \@d; $e .= "/"; } elsif ($TYPE{lc $ext} && -f $st) { $list = \@f; } $list and push @$list, TrivGal::Item->new($e); } @@ -316,7 +417,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 = ""; } } }