X-Git-Url: https://git.sesse.net/?a=blobdiff_plain;f=perl%2FSesse%2Fpr0n%2FCommon.pm;h=c85972191ae6835c377bd43166ff8a8bbfe1340a;hb=41782920ffb54fcfa21876a0257059f0d7ae89c3;hp=67c0c7721316673a943402ab26d902965295e5ed;hpb=5133c53d9f68b49bbf653f8a795e62a404e63f9d;p=pr0n diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm index 67c0c77..c859721 100644 --- a/perl/Sesse/pr0n/Common.pm +++ b/perl/Sesse/pr0n/Common.pm @@ -22,6 +22,7 @@ use HTML::Entities; use URI::Escape; use File::Basename; use Crypt::Eksblowfish::Bcrypt; +use File::Temp; BEGIN { use Exporter (); @@ -32,7 +33,7 @@ BEGIN { require Sesse::pr0n::Config_local; }; - $VERSION = "v3.02"; + $VERSION = "v3.20"; @ISA = qw(Exporter); @EXPORT = qw(&error &dberror); %EXPORT_TAGS = qw(); @@ -207,20 +208,20 @@ sub get_dbh { sub get_disk_location { my ($r, $id) = @_; - my $dir = POSIX::floor($id / 256); + my $dir = POSIX::floor($id / 256); return $Sesse::pr0n::Config::image_base . "images/$dir/$id.jpg"; } sub get_cache_location { - my ($id, $width, $height) = @_; - my $dir = POSIX::floor($id / 256); + my ($id, $width, $height, $format) = @_; + my $dir = POSIX::floor($id / 256); - return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-nobox.jpg"; + return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-nobox.$format"; } sub get_infobox_cache_location { my ($id, $width, $height, $dpr) = @_; - my $dir = POSIX::floor($id / 256); + my $dir = POSIX::floor($id / 256); if ($dpr == 1) { return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box.png"; @@ -248,7 +249,7 @@ sub ensure_disk_location_exists { sub get_mipmap_location { my ($r, $id, $width, $height) = @_; - my $dir = POSIX::floor($id / 256); + my $dir = POSIX::floor($id / 256); return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-mipmap-$width-$height.jpg"; } @@ -572,17 +573,21 @@ sub read_original_image { } sub ensure_cached { - my ($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres) = @_; - - my ($new_dbwidth, $new_dbheight); + my ($r, $avif_ok, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres) = @_; my $fname = get_disk_location($r, $id); unless (defined($xres) && (!defined($dbwidth) || !defined($dbheight) || $xres < $dbwidth || $yres < $dbheight || $xres == -1)) { return ($fname, undef); } - my $cachename = get_cache_location($id, $xres, $yres); - my $err; + # See if we have an up-to-date AVIF to serve. + # (We never generate them on-the-fly, since they're so slow.) + my $cachename = get_cache_location($id, $xres, $yres, 'avif'); + if ($avif_ok && -r $cachename and (-M $cachename <= -M $fname)) { + return ($cachename, 'image/avif'); + } + + $cachename = get_cache_location($id, $xres, $yres, 'jpg'); if (! -r $cachename or (-M $cachename > -M $fname)) { # If we are in overload mode (aka Slashdot mode), refuse to generate # new thumbnails. @@ -591,77 +596,112 @@ sub ensure_cached { error($r, 'System is in overload mode, not doing any scaling'); } - my $img; - ($img, $new_dbwidth, $new_dbheight) = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres); + make_cache($r, $filename, $id, $dbwidth, $dbheight, 'jpg', $xres, $yres, @otherres); + } - while (defined($xres) && defined($yres)) { - my ($nxres, $nyres) = (shift @otherres, shift @otherres); - my $cachename = get_cache_location($id, $xres, $yres); - - my $cimg; - if (defined($nxres) && defined($nyres)) { - # we have more resolutions to scale, so don't throw - # the image away - $cimg = $img->Clone(); - } else { - $cimg = $img; - } - - my $width = $img->Get('columns'); - my $height = $img->Get('rows'); - my ($nwidth, $nheight) = scale_aspect($width, $height, $xres, $yres); + return ($cachename, 'image/jpeg'); +} - my $filter = 'Lanczos'; - my $quality = 87; - my $sf = "1x1"; +sub make_cache { + my ($r, $filename, $id, $dbwidth, $dbheight, $format, $xres, $yres, @otherres) = @_; - if ($xres != -1) { - $cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter, 'sampling-factor'=>$sf); - } + my ($img, $new_dbwidth, $new_dbheight) = make_mipmap($r, $filename, $id, $dbwidth, $dbheight, $xres, $yres, @otherres); - # Strip EXIF tags etc. - $cimg->Strip(); + # Update the SQL database if it doesn't contain the required info + if (!defined($dbwidth) && defined($new_dbwidth)) { + log_info($r, "Updating width/height for $id: $new_dbwidth x $new_dbheight"); + update_image_info($r, $id, $new_dbwidth, $new_dbheight); + } - { - my %parms = ( - filename => $cachename, - quality => $quality - ); - if (($nwidth >= 640 && $nheight >= 480) || - ($nwidth >= 480 && $nheight >= 640)) { - $parms{'interlace'} = 'Plane'; - } - if (defined($sf)) { - $parms{'sampling-factor'} = $sf; - } - $err = $cimg->write(%parms); - } + my $err; + while (defined($xres) && defined($yres)) { + my ($nxres, $nyres) = (shift @otherres, shift @otherres); + my $cachename = get_cache_location($id, $xres, $yres, $format); + + my $cimg; + if (defined($nxres) && defined($nyres)) { + # we have more resolutions to scale, so don't throw + # the image away + $cimg = $img->Clone(); + } else { + $cimg = $img; + } + + my $width = $img->Get('columns'); + my $height = $img->Get('rows'); + my ($nwidth, $nheight) = scale_aspect($width, $height, $xres, $yres); - undef $cimg; + if ($format eq 'avif') { # AVIF uses 4:2:0. + ++$nwidth if ($nwidth % 2 == 1); + ++$nheight if ($nheight % 2 == 1); + } - ($xres, $yres) = ($nxres, $nyres); + my $filter = 'Lanczos'; + my $quality = 87; + my $sf = "1x1"; - log_info($r, "New cache: $nwidth x $nheight for $id.jpg"); + if ($xres != -1) { + $cimg->Resize(width=>$nwidth, height=>$nheight, filter=>$filter); } - - undef $img; - if ($err) { - log_warn($r, "$fname: $err"); - $err =~ /(\d+)/; - if ($1 >= 400) { - #@$magick = (); - error($r, "$fname: $err"); + + # Strip EXIF tags etc. + $cimg->Strip(); + + if ($format eq 'jpg') { + my %parms = ( + filename => $cachename, + quality => $quality + ); + if (($nwidth >= 640 && $nheight >= 480) || + ($nwidth >= 480 && $nheight >= 640)) { + $parms{'interlace'} = 'Plane'; + } + if (defined($sf)) { + $parms{'sampling-factor'} = $sf; } + $err = $cimg->write(%parms); + } elsif ($format eq 'avif') { + # ImageMagick doesn't have AVIF support until version 7, + # and Debian hasn't packaged that even in unstable as of 2021. + # So we'll need to do it the manual way. (We don't use /tmp, for security reasons.) + (my $dirname = $cachename) =~ s,/[^/]*$,,; + my ($fh, $raw_filename) = File::Temp::tempfile('tmp.XXXXXXXX', DIR => $dirname, SUFFIX => '.yuv'); + # Write a Y4M header, so that we get the chroma siting and color space correct. + printf $fh "YUV4MPEG2 W%d H%d F25:1 Ip A1:1 C420jpeg XYSCSS=420JPEG XCOLORRANGE=FULL\nFRAME\n", $nwidth, $nheight; + my %parms = ( + file => $fh, + filename => $raw_filename, + 'sampling-factor' => '2x2' + ); + $cimg->write(%parms); + close($fh); + my $ivf_filename; + ($fh, $ivf_filename) = File::Temp::tempfile('tmp.XXXXXXXX', DIR => $dirname, SUFFIX => '.ivf'); + close($fh); + system('aomenc', '--quiet', '--cpu-used=0', '--bit-depth=10', '--end-usage=q', '--cq-level=10', '--target-bitrate=0', '--good', '--aq-mode=1', '--color-primaries=bt601', '--matrix-coefficients=bt601', '-o', $ivf_filename, $raw_filename); + unlink($raw_filename); + system('MP4Box', '-quiet', '-add-image', "$ivf_filename:primary", '-ab', 'avif', '-ab', 'miaf', '-new', $cachename); + unlink($ivf_filename); + } else { + die "Unknown format $format"; } + + undef $cimg; + + ($xres, $yres) = ($nxres, $nyres); + + log_info($r, "New cache: $nwidth x $nheight ($format) for $id"); } - # Update the SQL database if it doesn't contain the required info - if (!defined($dbwidth) && defined($new_dbwidth)) { - log_info($r, "Updating width/height for $id: $new_dbwidth x $new_dbheight"); - update_image_info($r, $id, $new_dbwidth, $new_dbheight); + undef $img; + if ($err) { + log_warn($r, "$filename: $err"); + $err =~ /(\d+)/; + if ($1 >= 400) { + #@$magick = (); + error($r, "$filename: $err"); + } } - - return ($cachename, 'image/jpeg'); } sub ensure_infobox_cached { @@ -817,13 +857,13 @@ sub make_infobox { $model =~ s/^\s+//; $model =~ s/\s+$//; - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ $model, 0 ]; } # classic fields if (scalar @classic_fields > 0) { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); my $first_elem = 1; for my $field (@classic_fields) { @@ -838,14 +878,14 @@ sub make_infobox { $info->{'Flash'} =~ /no flash/i || $info->{'Flash'} =~ /not fired/i || $info->{'Flash'} =~ /Off/) { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ "No flash", 0 ]; } elsif ($info->{'Flash'} =~ /fired/i || $info->{'Flash'} =~ /On/) { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ "Flash", 0 ]; } else { - push @parts, [ ' - ', 0 ] if (scalar @parts > 0); + push @parts, [ "\x{00A0}\x{2013}\x{00A0}", 0 ] if (scalar @parts > 0); push @parts, [ $info->{'Flash'}, 0 ]; } } @@ -1032,7 +1072,7 @@ sub get_server_name { sub log_info { my ($r, $msg) = @_; - if (defined($r->logger)) { + if (defined($r->{'logger'})) { $r->logger->({ level => 'info', message => $msg }); } else { print STDERR "[INFO] $msg\n"; @@ -1041,7 +1081,7 @@ sub log_info { sub log_warn { my ($r, $msg) = @_; - if (defined($r->logger)) { + if (defined($r->{'logger'})) { $r->logger->({ level => 'warn', message => $msg }); } else { print STDERR "[WARN] $msg\n"; @@ -1050,7 +1090,7 @@ sub log_warn { sub log_error { my ($r, $msg) = @_; - if (defined($r->logger)) { + if (defined($r->{'logger'})) { $r->logger->({ level => 'error', message => $msg }); } else { print STDERR "[ERROR] $msg\n";