X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/tgal/blobdiff_plain/4e74ddf4ab1a4c3a7a3b9936a978f225a690aa7d..33b14649a11c8450f7d401a2109737e0063d5ff2:/mason/.perl-lib/TrivGal.pm diff --git a/mason/.perl-lib/TrivGal.pm b/mason/.perl-lib/TrivGal.pm index 838de97..4e01f51 100644 --- a/mason/.perl-lib/TrivGal.pm +++ b/mason/.perl-lib/TrivGal.pm @@ -30,6 +30,7 @@ use autodie qw{:all}; use Errno; use Exporter qw{import}; use File::stat; +use Image::ExifTool qw{}; use Image::Imlib2; use User::pwent; use POSIX; @@ -55,10 +56,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 +69,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 +81,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,8 +141,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; @@ -182,6 +194,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; @@ -197,15 +219,20 @@ package TrivGal::Image { }, $cls; } - sub scale ($$) { - my ($me, $scale) = @_; + 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 $thumburl = + $m->interp->apply_escapes("$CACHEURL/scale.$sz/$path", "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'"; @@ -213,21 +240,30 @@ package TrivGal::Image { 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 ($wd, $ht) = ($img->width, $img->height); my $max = $wd > $ht ? $wd : $ht; - if ($max <= $sz) { return "$IMGURL/$path"; } + if ($max <= $sz) + { return $m->interp->apply_escapes("$IMGURL/$path", "u"); } 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; + 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; } @@ -257,6 +293,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; @@ -269,29 +306,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; @@ -301,8 +348,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); } @@ -335,7 +382,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 = ""; } } }