Move from mod_perl to being a PSGI app.
[pr0n] / 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                 print STDERR "Could not load the qscale module ($@); continuing with ImageMagick only.\n";
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