git.sesse.net Git - pr0n/blob - perl/Sesse/pr0n/QscaleProxy.pm

   1 # An object that looks a bit like an Image::Magick object, but has a lot fewer
   2 # methods, and can use qscale behind-the-scenes instead if possible.
   3
   4 package Sesse::pr0n::QscaleProxy;
   5 use strict;
   6 use warnings;
   7
   8 use Image::Magick;
   9
  10 our $has_qscale;
  11
  12 BEGIN {
  13         $has_qscale = 0;
  14         eval {
  15                 require qscale;
  16                 $has_qscale = 1;
  17         };
  18         if ($@) {
  19                 Apache2::ServerUtil->server->log_error("Could not load the qscale module ($@); continuing with ImageMagick only.");
  20         }
  21 }
  22
  23 sub new {
  24         my $ref = {};
  25
  26         if (!$has_qscale) {
  27                 $ref->{'magick'} = Image::Magick->new;
  28         }
  29
  30         bless $ref;
  31         return $ref;
  32 }
  33
  34 sub DESTROY {
  35         my ($self) = @_;
  36
  37         if (exists($self->{'qscale'})) {
  38                 qscale::qscale_destroy($self->{'qscale'});
  39                 delete $self->{'qscale'};
  40         }
  41 }
  42
  43 sub Clone {
  44         my ($self) = @_;
  45
  46         if (exists($self->{'magick'})) {
  47                 return $self->{'magick'}->Clone();
  48         }
  49
  50         my $clone = Sesse::pr0n::QscaleProxy->new;
  51         $clone->{'qscale'} = qscale::qscale_clone($self->{'qscale'});
  52         return $clone;
  53 }
  54
  55 sub Get {
  56         my ($self, $arg) = @_;
  57
  58         if (exists($self->{'magick'})) {
  59                 return $self->{'magick'}->Get($arg);
  60         }
  61
  62         if ($arg eq 'rows') {
  63                 return $self->{'qscale'}->{'height'};
  64         } elsif ($arg eq 'columns') {
  65                 return $self->{'qscale'}->{'width'};
  66         } else {
  67                 die "Unknown attribute '$arg'";
  68         }
  69 }
  70
  71 sub Read {
  72         my ($self, @args) = @_;
  73
  74         if (exists($self->{'magick'})) {
  75                 return $self->{'magick'}->Read(@args);
  76         }
  77         if (exists($self->{'qscale'})) {
  78                 qscale::qscale_destroy($self->{'qscale'});
  79                 delete $self->{'qscale'};
  80         }
  81
  82         # Small hack
  83         if (scalar @args == 1) {
  84                 @args = ( filename => $args[0] );
  85         }
  86
  87         my %args = @args;
  88         my $qscale;
  89         if (exists($args{'filename'})) {
  90                 $qscale = qscale::qscale_load_jpeg($args{'filename'});
  91         } elsif (exists($args{'file'})) {
  92                 $qscale = qscale::qscale_load_jpeg_from_stdio($args{'file'});
  93         } else {
  94                 die "Missing a file or file name to load JPEG from";
  95         }
  96
  97         if (qscale::qscale_is_invalid($qscale)) {
  98                 return "400 Image loading failed";
  99         }
 100         $self->{'qscale'} = $qscale;
 101         return 0;
 102 }
 103
 104 # Note: sampling-factor is not an ImageMagick parameter; it's qscale specific.
 105 sub Resize {
 106         my ($self, %args) = @_;
 107
 108         if (exists($self->{'magick'})) {
 109                 return $self->{'magick'}->Resize(%args);
 110         }
 111
 112         if (!(exists($args{'width'}) &&
 113               exists($args{'height'}) &&
 114               exists($args{'filter'}) &&
 115               exists($args{'sampling-factor'}))) {
 116                 die "Need arguments width, height, filter and sampling-factor.";
 117         }
 118
 119         my $samp_h0 = 2;
 120         my $samp_v0 = 2;
 121         if (defined($args{'sampling-factor'}) && $args{'sampling-factor'} =~ /^(\d)x(\d)$/) {
 122                 $samp_h0 = $1;
 123                 $samp_v0 = $2;
 124         }
 125
 126         my $samp_h1 = 1;
 127         my $samp_v1 = 1;
 128         my $samp_h2 = 1;
 129         my $samp_v2 = 1;
 130
 131         my $filter;
 132         if ($args{'filter'} eq 'Lanczos') {
 133                 $filter = $qscale::LANCZOS;
 134         } elsif ($args{'filter'} eq 'Mitchell') {
 135                 $filter = $qscale::MITCHELL;
 136         } else {
 137                 die "Unknown filter " . $args{'filter'};
 138         }
 139
 140         my $nqscale = qscale::qscale_scale($self->{'qscale'}, $args{'width'}, $args{'height'}, $samp_h0, $samp_v0, $samp_h1, $samp_v1, $samp_h2, $samp_v2, $filter);
 141         qscale::qscale_destroy($self->{'qscale'});
 142         $self->{'qscale'} = $nqscale;
 143
 144         return 0;
 145 }
 146
 147 sub Strip {
 148         my ($self) = @_;
 149
 150         if (exists($self->{'magick'})) {
 151                 $self->{'magick'}->Strip();
 152         }
 153 }
 154
 155 sub write {
 156         my ($self, %args) = @_;
 157
 158         if (exists($self->{'magick'})) {
 159                 return $self->{'magick'}->write(%args);
 160         }
 161
 162         # For some reason we seem to get conditions of some sort when using
 163         # qscale for this, but not when using ImageMagick. Thus, we put the
 164         # atomic-write code here and not elsewhere in pr0n.
 165         my $filename = $args{'filename'};
 166         my $quality = $args{'quality'};
 167
 168         my $jpeg_mode;
 169         if (!defined($args{'interlace'})) {
 170                 $jpeg_mode = $qscale::SEQUENTIAL;
 171         } elsif ($args{'interlace'} eq 'Plane') {
 172                 $jpeg_mode = $qscale::PROGRESSIVE;
 173         } else {
 174                 die "Unknown interlacing mode " . $args{'interlace'};
 175         }
 176
 177         my $tmpname = $filename . "-tmp-$$-" . int(rand(100000));
 178         unlink($filename);
 179         my $ret = qscale::qscale_save_jpeg($self->{'qscale'}, $tmpname, $quality, $jpeg_mode);
 180         if ($ret == 0) {
 181                 if (rename($tmpname, $filename)) {
 182                         return 0;
 183                 } else {
 184                         return "400 Image renaming to from $tmpname to $filename failed: $!";
 185                 }
 186         } else {
 187                 return "400 Image saving to $tmpname failed";
 188         }
 189 }
 190
 191 1;
 192