File Coverage

blib/lib/Image/Base/Imager.pm
Criterion Covered Total %
statement 115 121 95.0
branch 54 62 87.1
condition 7 9 77.7
subroutine 19 20 95.0
pod 10 12 83.3
total 205 224 91.5


line stmt bran cond sub pod time code
1             # Copyright 2010, 2011, 2012, 2019 Kevin Ryde
2              
3             # This file is part of Image-Base-Imager.
4             #
5             # Image-Base-Imager is free software; you can redistribute it and/or modify
6             # it under the terms of the GNU General Public License as published by the
7             # Free Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Image-Base-Imager is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Image-Base-Imager. If not, see .
17              
18              
19              
20             # cf Imager::Draw -- drawing operations
21             # Seems to auto-clip to width,height.
22              
23             package Image::Base::Imager;
24 3     3   54542 use 5.004;
  3         19  
25 3     3   18 use strict;
  3         6  
  3         74  
26 3     3   16 use Carp;
  3         6  
  3         190  
27              
28             # maybe Imager 0.39 of Nov 2001 for oop style tags, or something post 0.20
29             # for the oopery, but don't think need to force that here (just list in the
30             # Makefile.PL PREREQ_PM)
31 3     3   1778 use Imager;
  3         90462  
  3         20  
32              
33 3     3   171 use vars '$VERSION', '@ISA';
  3         7  
  3         156  
34              
35 3     3   1593 use Image::Base;
  3         5422  
  3         4868  
36             @ISA = ('Image::Base');
37              
38             $VERSION = 14;
39              
40             # uncomment this to run the ### lines
41             # use Smart::Comments '###';
42              
43              
44             # As of Imager 0.79 there's nothing to set the Zlib compression level for a
45             # -zlib_compression attribute.
46             #
47             # An -allow_partial could set allow_partial=> on read().
48             #
49              
50             sub new {
51 26     26 1 15208 my ($class, %params) = @_;
52             ### Image-Base-Imager new(): %params
53              
54             # $obj->new(...) means make a copy, with some extra settings
55 26 100       80 if (ref $class) {
56 1         4 my $self = $class;
57 1         2 $class = ref $class;
58 1 50       4 if (! defined $params{'-imager'}) {
59 1         4 $params{'-imager'} = $self->get('-imager')->copy;
60             }
61             # inherit everything else
62 1         75 %params = (%$self, %params);
63             ### copy params: \%params
64             }
65              
66 26         42 my $want_load = 1;
67 26 100       64 if (! defined $params{'-imager'}) {
68 22         40 my $width = delete $params{'-width'};
69 22         36 my $height = delete $params{'-height'};
70 22         42 my $filename = $params{'-file'};
71 22 100       45 if (! defined $filename) {
72             # default 1x1 image since xsize=>undef,ysize=>undef is a 0x0
73             # nothingness where settag() won't store -file_format
74 19 100       39 if (! defined $width) { $width = 1; }
  4         17  
75 19 100       39 if (! defined $height) { $height = 1; }
  4         6  
76             }
77 22   66     93 $params{'-imager'} = Imager->new (xsize => $width,
78             ysize => $height,
79             file => $filename)
80             || croak "Cannot create image: ",Imager->errstr;
81             # set -file as filename, but have already loaded
82 21         1489 $want_load = 0;
83             }
84 25         53 my $self = bless {}, $class;
85 25         86 $self->set (%params);
86              
87 25 50 66     76 if ($want_load && defined $params{'-file'}) {
88 0         0 $self->load;
89             }
90              
91             ### new made: $self
92 25         73 return $self;
93             }
94              
95              
96             my %attr_to_tag = (-hotx => 'cur_hotspotx', # get and set
97             -hoty => 'cur_hotspoty',
98             );
99             my %attr_to_get_method = (-width => 'getwidth',
100             -height => 'getheight',
101             -ncolours => 'colorcount',
102             -file_format => \&_imager_get_file_format,
103             );
104             sub _get {
105 1033     1033   72572 my ($self, $key) = @_;
106             ### Image-Base-Imager _get(): $key
107              
108 1033 100       2404 if (my $tag = $attr_to_tag{$key}) {
109             ### $tag
110             ### is: [$self->{'-imager'}->tags(name=>$tag)]
111 6         27 return scalar(($self->{'-imager'}->tags(name=>$tag))[0]);
112             }
113 1027 100       1959 if (my $method = $attr_to_get_method{$key}) {
114             ### $method
115             ### is: $self->{'-imager'}->$method()
116 1024         3470 return $self->{'-imager'}->$method();
117             }
118 3         21 return $self->SUPER::_get ($key);
119             }
120             sub _imager_get_file_format {
121 19     19   28 my ($i) = @_;
122             ### _imager_get_file_format() from tags: [$i->tags]
123             # tags() returns a list of the values
124 19         60 return scalar(($i->tags (name => 'i_format'))[0]);
125             }
126              
127             my %attr_to_img_set = (-width => 'xsize',
128             -height => 'ysize',
129             );
130             sub set {
131 45     45 1 3284 my ($self, %param) = @_;
132             ### Image-Base-Imager set(): \%param
133              
134 45         85 foreach my $key ('-ncolours') {
135 45 50       117 if (exists $param{$key}) {
136 0         0 croak "Attribute $key is read-only";
137             }
138             }
139              
140             # apply this first
141 45 100       100 if (my $i = delete $param{'-imager'}) {
142 25         61 $self->{'-imager'} = $i;
143             }
144              
145 45         71 my $i = $self->{'-imager'};
146 45 100       80 if (exists $param{'-file_format'}) {
147 11         22 my $format = delete $param{'-file_format'};
148 11 100       23 if (defined $format) { $format = lc($format); }
  10         22  
149             ### apply -file_format with settag() i_format: $format
150 11         33 $i->settag (name => 'i_format', value => $format);
151             ### tags now: [$i->tags]
152             }
153 45         735 foreach my $key (keys %param) {
154 32 100       226 if (my $tag = $attr_to_tag{$key}) {
155             ### settag: $tag
156 6         19 $i->settag (name => $tag, value => delete $param{$key});
157             ### tags now: [$i->tags]
158             }
159             }
160              
161 45         207 my @set;
162 45         71 foreach my $key (keys %param) {
163 26 100       59 if (my $attribute = $attr_to_img_set{$key}) {
164 4         10 push @set, $attribute, delete $param{$key};
165             }
166             }
167 45 100       88 if (@set) {
168             ### @set
169 2         5 $i->img_set(@set);
170             }
171              
172 45         226 %$self = (%$self, %param);
173             }
174              
175             sub load {
176 2     2 1 11 my ($self, $filename) = @_;
177             ### Image-Base-Imager load(): @_
178 2 50       6 if (@_ == 1) {
179 0         0 $filename = $self->get('-file');
180             } else {
181 2         5 $self->set('-file', $filename);
182             }
183 2         4 my $i = $self->{'-imager'};
184 2 100       7 $i->read (file => $filename)
185             or croak "Cannot load: ",$i->errstr;
186             ### $i
187             ### size: $i->getwidth.'x'.$i->getheight
188             ### tags: [$i->tags]
189             }
190              
191             # not yet documented ...
192             sub load_fh {
193 1     1 0 44 my ($self, $fh) = @_;
194 1         5 my $i = $self->{'-imager'};
195 1 50       5 $i->read (fh => $fh)
196             or croak "Cannot load: ",$i->errstr;
197             }
198              
199             sub save {
200 12     12 1 139 my ($self, $filename) = @_;
201             ### Image-Base-Imager save(): @_
202 12 50       26 if (@_ == 2) {
203 12         25 $self->set('-file', $filename);
204             } else {
205 0         0 $filename = $self->get('-file');
206             }
207 12         22 my $i = $self->{'-imager'};
208 12         28 my $type = _imager_get_file_format($i);
209 12         326 my $quality = $self->{'-quality_percent'};
210             ### file: $filename
211             ### type: $type
212              
213             # think it's ok to pass undef as $quality, and that the options can be
214             # passed even when not saving to the respective formats
215 12 100       34 $i->write (file => $filename,
216             type => $type,
217             jpegquality => $quality,
218             tiff_jpegquality => $quality)
219             or croak "Cannot save: ",$i->errstr;
220             }
221              
222             # not yet documented ...
223             sub save_fh {
224 1     1 0 854 my ($self, $fh) = @_;
225 1         5 my $i = $self->{'-imager'};
226 1 50       4 $i->write (fh => $fh,
227             type => _imager_get_file_format($i))
228             or croak "Cannot save: ",$i->errstr;
229             }
230              
231             sub xy {
232 2722     2722 1 227692 my ($self, $x, $y, $colour) = @_;
233             ### Image-Base-Imager xy: $x,$y,$colour
234 2722         5254 my $i = $self->{'-imager'};
235 2722 100       5528 if (@_ == 4) {
236 42         99 $i->setpixel (x => $x, y => $y, color => $colour);
237              
238             } else {
239 2680         7584 my $cobj = $i->getpixel (x => $x, y => $y);
240 2680 100       72370 if (! defined $cobj) {
241             # getpixel() returns undef if x,y outside image size
242 6         22 return undef;
243             }
244 2674         8386 my @rgba = $cobj->rgba;
245             ### @rgba
246             # if ($a == 0) {
247             # return 'None';
248             # }
249 2674         19097 return sprintf ('#%02X%02X%02X', @rgba[0,1,2]);
250             }
251             }
252             sub line {
253 40     40 1 5356 my ($self, $x1, $y1, $x2, $y2, $colour) = @_;
254             ### Image-Base-Imager line: @_
255 40         121 $self->{'-imager'}->line (x1 => $x1,
256             y1 => $y1,
257             x2 => $x2,
258             y2 => $y2,
259             color => $colour);
260             }
261             sub rectangle {
262 170     170 1 16327 my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
263             ### Image-Base-Imager rectangle: @_
264              
265 170         577 $self->{'-imager'}->box (xmin => $x1,
266             ymin => $y1,
267             xmax => $x2,
268             ymax => $y2,
269             color => $colour,
270             filled => $fill);
271             }
272              
273             sub ellipse {
274 26     26 1 3377 my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
275             ### Image-Base-Imager ellipse: "$x1, $y1, $x2, $y2, $colour"
276              
277 26         48 my $diam = $x2-$x1;
278 26 100 100     116 if (! ($diam & 1) && $y2-$y1 == $diam) {
279             ### use circle
280 6         46 $self->{'-imager'}->circle (x => ($x2+$x1)/2,
281             y => ($y2+$y1)/2,
282             r => $diam/2,
283             color => $colour,
284             filled => $fill);
285             } else {
286             ### use superclass ellipse
287 20         75 shift->SUPER::ellipse (@_);
288             }
289             }
290              
291             sub diamond {
292 26     26 1 3372 my ($self, $x1, $y1, $x2, $y2, $colour, $fill) = @_;
293             ### Image-Base-Imager diamond() ...
294              
295             # $imager->polygon() for filled poly is always anti-alias, but don't want
296             # that, or not by default, so polyline() for unfilled and Image::Base for
297             # filled
298              
299 26 100       59 if ($fill) {
300 13         53 shift->SUPER::diamond(@_);
301              
302             } else {
303             # 0 1 2 3 4
304             # x1=0, x2=4 -> xh=2
305             #
306             # 0 1 2 3 4 5
307             # x1=0, x2=5 -> xh=2
308             #
309 13         30 my $xh = ($x2 - $x1);
310 13         19 my $yh = ($y2 - $y1);
311 13         24 my $xeven = ($xh & 1);
312 13         18 my $yeven = ($yh & 1);
313 13         32 $xh = int($xh / 2);
314 13         21 $yh = int($yh / 2);
315             ### assert: $x1+$xh == $x2-$xh || $x1+$xh+1 == $x2-$xh
316             ### assert: $y1+$yh == $y2-$yh || $y1+$yh+1 == $y2-$yh
317              
318 13 100       126 $self->{'-imager'}->polyline (points => [ [$x1+$xh,$y1], # top centre
    100          
    100          
    100          
    50          
319              
320             # left
321             [$x1,$y1+$yh],
322             ($yeven ? [$x1,$y2-$yh] : ()),
323              
324             # bottom
325             [$x1+$xh,$y2],
326             ($xeven ? [$x2-$xh,$y2] : ()),
327              
328             # right
329             ($yeven ? [$x2,$y2-$yh] : ()),
330             [$x2,$y1+$yh],
331              
332             ($xeven ? [$x2-$xh,$y1] : ()),
333             ($fill ? () : [$x1+$xh,$y1]),
334             ],
335             color => $colour);
336             }
337             }
338              
339             #------------------------------------------------------------------------------
340             # colours
341              
342             sub add_colours {
343 0     0 1   my $self = shift;
344             ### add_colours: @_
345 0           $self->{'-imager'}->addcolors (colors => \@_);
346             }
347              
348              
349             # sub _validate_file_format {
350             # my ($format) = @_;
351             # if (! defined $format) {
352             # return; # undef is ok
353             # }
354             #
355             # # in Imager 0.80 'cur' works but isn't in the types lists
356             # my $lform = lc($format);
357             # foreach my $f ('cur', Imager->read_types, Imager->write_types) {
358             # if ($lform eq $f) {
359             # return;
360             # }
361             # }
362             #
363             # croak 'Unrecognised -file_format: ',$format;
364             # }
365              
366             1;
367             __END__