X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/tgal/blobdiff_plain/1408b7a293e5a35d99744aaa51192eab972a95a1..2c1f91c4c2441cde00590f88efc5e0553783410f:/mason/.perl-lib/TrivGal.pm diff --git a/mason/.perl-lib/TrivGal.pm b/mason/.perl-lib/TrivGal.pm index 5b5cbfa..594b383 100644 --- a/mason/.perl-lib/TrivGal.pm +++ b/mason/.perl-lib/TrivGal.pm @@ -30,7 +30,9 @@ use autodie qw{:all}; use Errno; use Exporter qw{import}; use File::stat; +use Image::ExifTool qw{}; use Image::Imlib2; +use Image::Size qw{}; use User::pwent; use POSIX; @@ -55,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; @@ -68,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); @@ -77,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; } @@ -137,10 +142,15 @@ 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 => 228, + small => 480, + embed => 720, view => 1200); export qw{init}; @@ -185,6 +195,16 @@ sub clean_temp_files () { ###-------------------------------------------------------------------------- ### 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; @@ -194,43 +214,69 @@ 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, + _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 sz ($) { my ($me) = @_; $me->_getsz; return $me->{sz}; } + + 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"; + if ($me->sz <= $sz) + { return $m->interp->apply_escapes("$IMGURL/$path", "u"); } + + my $tail = "scale.$sz/$path"; + my $thumb = "$CACHE/$tail"; + my $thumburl = $m->interp->apply_escapes("$CACHEURL/$tail", "u"); my $st = stat $thumb; if (defined $st && $st->mtime > $me->{mtime}) { return $thumburl; } + return + $m->interp->apply_escapes("$SCRIPTURL/$path", "u") . "?scale=$scale" + unless $forcep; 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"; - $img = $me->{img} = Image::Imlib2->load($imgpath); + my $exif = new Image::ExifTool; + $exif->ExtractInfo($me->{imgpath}); + my $orient = $exif->GetValue("Orientation", "ValueConv"); + $img = $me->{img} = Image::Imlib2->load($me->{imgpath}); + if (defined $orient) { + my ($rot, $flip) = @{$ORIENT{$orient}}; + if ($rot) { $img->image_orientate($rot); } + if ($flip) { $img->flip_horizontal(); } + } } - my ($wd, $ht) = ($img->width, $img->height); - my $max = $wd > $ht ? $wd : $ht; - if ($max <= $sz) { return "$IMGURL/$path"; } - my $sc = $sz/$max; + 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; + my $new = "$TMP/t$$-$ext"; + make_path $TMP, { mode => 0771 }; $scaled->save($new); - make_path $dir; + make_path $dir, { mode => 0771 }; rename $new, $thumb; return $thumburl; } @@ -260,6 +306,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; @@ -272,29 +319,39 @@ 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 ($dir, $base, $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; @@ -304,8 +361,8 @@ sub listdir ($) { 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); } @@ -338,7 +395,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 = ""; } } }