File Coverage

/root/.cpan/build/Imager-1.019-0/blib/lib/Imager.pm
Criterion Covered Total %
statement 1686 2240 75.2
branch 981 1406 69.7
condition 191 338 56.5
subroutine 141 159 88.6
pod 1 105 0.9
total 3000 4248 70.6


line stmt bran cond sub pod time code
1             package Imager;
2 58     58   2068388 use 5.006;
  58         559  
3              
4 58     58   270 use strict;
  58         92  
  58         1338  
5 58     58   294 use Scalar::Util;
  58         100  
  58         2608  
6 58     58   21546 use Imager::Color;
  58         125  
  58         1891  
7 58     58   22190 use Imager::Color::Float;
  58         139  
  58         1650  
8 58     58   23301 use Imager::Font;
  58         166  
  58         1687  
9 58     58   20737 use Imager::TrimColorList;
  58         119  
  58         2296  
10 58     58   30553 use if $] >= 5.014, "warnings::register" => qw(tagcodes channelmask);
  58         665  
  58         470  
11              
12             our $ERRSTR;
13              
14             our @EXPORT_OK = qw(
15             init
16             init_log
17             DSO_open
18             DSO_close
19             DSO_funclist
20             DSO_call
21              
22             load_plugin
23             unload_plugin
24              
25             i_list_formats
26              
27             i_color_new
28             i_color_set
29             i_color_info
30              
31             i_img_info
32              
33             i_img_setmask
34             i_img_getmask
35              
36             i_line
37             i_line_aa
38             i_box
39             i_box_filled
40             i_arc
41             i_circle_aa
42              
43             i_bezier_multi
44             i_poly_aa
45             i_poly_aa_cfill
46              
47             i_copyto
48             i_rubthru
49             i_scaleaxis
50             i_scale_nn
51             i_haar
52             i_count_colors
53              
54             i_gaussian
55             i_conv
56              
57             i_convert
58             i_map
59              
60             i_img_diff
61              
62             i_tt_set_aa
63             i_tt_cp
64             i_tt_text
65             i_tt_bbox
66              
67             i_readpnm_wiol
68             i_writeppm_wiol
69              
70             i_readraw_wiol
71             i_writeraw_wiol
72              
73             i_contrast
74             i_hardinvert
75             i_noise
76             i_bumpmap
77             i_postlevels
78             i_mosaic
79             i_watermark
80              
81             malloc_state
82              
83             list_formats
84              
85             i_gifquant
86              
87             newfont
88             newcolor
89             newcolour
90             NC
91             NF
92             NCF
93             );
94              
95             our @EXPORT=qw(
96             );
97              
98             our %EXPORT_TAGS=
99             (handy => [qw(
100             newfont
101             newcolor
102             NF
103             NC
104             NCF
105             )],
106             all => [@EXPORT_OK],
107             default => [qw(
108             load_plugin
109             unload_plugin
110             )]);
111              
112             # registered file readers
113             my %readers;
114              
115             # registered file writers
116             my %writers;
117              
118             # modules we attempted to autoload
119             my %attempted_to_load;
120              
121             # errors from loading files
122             my %file_load_errors;
123              
124             # what happened when we tried to load
125             my %reader_load_errors;
126             my %writer_load_errors;
127              
128             # library keys that are image file formats
129             my %file_formats = map { $_ => 1 } qw/tiff pnm gif png jpeg raw bmp tga/;
130              
131             # image pixel combine types
132             my @combine_types =
133             qw/none normal multiply dissolve add subtract diff lighten darken
134             hue saturation value color/;
135             my %combine_types;
136             @combine_types{@combine_types} = 0 .. $#combine_types;
137             $combine_types{mult} = $combine_types{multiply};
138             $combine_types{'sub'} = $combine_types{subtract};
139             $combine_types{sat} = $combine_types{saturation};
140              
141             # this will be used to store global defaults at some point
142             my %defaults;
143              
144             our $VERSION;
145              
146             BEGIN {
147 58     58   24586 require Exporter;
148 58         2891 my $ex_version = eval $Exporter::VERSION;
149 58 50       319 if ($ex_version < 5.57) {
150 0         0 our @ISA = qw(Exporter);
151             }
152 58         102 $VERSION = '1.019';
153 58         220 require XSLoader;
154 58         160212 XSLoader::load(Imager => $VERSION);
155             }
156              
157             my %formats_low;
158             my %format_classes =
159             (
160             png => "Imager::File::PNG",
161             gif => "Imager::File::GIF",
162             tiff => "Imager::File::TIFF",
163             jpeg => "Imager::File::JPEG",
164             w32 => "Imager::Font::W32",
165             ft2 => "Imager::Font::FT2",
166             t1 => "Imager::Font::T1",
167             );
168              
169             our %formats;
170              
171             tie %formats, "Imager::FORMATS", \%formats_low, \%format_classes;
172              
173             our %filters;
174              
175             our $DEBUG;
176             our %OPCODES;
177             our $FORMATGUESS;
178             our $warn_obsolete;
179              
180             BEGIN {
181 58     58   1428 for(i_list_formats()) { $formats_low{$_}++; }
  290         620  
182              
183 58         713 %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
184              
185 58         125 $DEBUG=0;
186              
187             # the members of the subhashes under %filters are:
188             # callseq - a list of the parameters to the underlying filter in the
189             # order they are passed
190             # callsub - a code ref that takes a named parameter list and calls the
191             # underlying filter
192             # defaults - a hash of default values
193             # names - defines names for value of given parameters so if the names
194             # field is foo=> { bar=>1 }, and the user supplies "bar" as the
195             # foo parameter, the filter will receive 1 for the foo
196             # parameter
197             $filters{contrast}={
198             callseq => ['image','intensity'],
199 1         3 callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
  1         1484  
200 58         481 };
201              
202             $filters{noise} ={
203             callseq => ['image', 'amount', 'subtype'],
204             defaults => { amount=>3,subtype=>0 },
205 1         3 callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
  1         2127  
206 58         405 };
207              
208             $filters{hardinvert} ={
209             callseq => ['image'],
210             defaults => { },
211 3         7 callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
  3         1152  
212 58         274 };
213              
214             $filters{hardinvertall} =
215             {
216             callseq => ['image'],
217             defaults => { },
218 2         5 callsub => sub { my %hsh=@_; i_hardinvertall($hsh{image}); }
  2         179  
219 58         310 };
220              
221             $filters{autolevels_skew} ={
222             callseq => ['image','lsat','usat','skew'],
223             defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
224 1         3 callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
  1         2961  
225 58         390 };
226              
227             $filters{autolevels} ={
228             callseq => ['image','lsat','usat'],
229             defaults => { lsat=>0.1,usat=>0.1 },
230 3         8 callsub => sub { my %hsh=@_; i_autolevels_mono($hsh{image},$hsh{lsat},$hsh{usat}); }
  3         1746  
231 58         334 };
232              
233             $filters{turbnoise} ={
234             callseq => ['image'],
235             defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
236 1         4 callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
  1         60824  
237 58         346 };
238              
239             $filters{radnoise} ={
240             callseq => ['image'],
241             defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
242 1         3 callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
  1         63193  
243 58         535 };
244              
245             $filters{conv} =
246             {
247             callseq => ['image', 'coef'],
248             defaults => { },
249             callsub =>
250             sub {
251 46         150 my %hsh=@_;
252             i_conv($hsh{image},$hsh{coef})
253 46 100       454525 or die Imager->_error_as_msg() . "\n";
254             }
255 58         370 };
256              
257             $filters{gradgen} =
258             {
259             callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
260             defaults => { dist => 0 },
261             callsub =>
262             sub {
263 1         3 my %hsh=@_;
264 1         2 my @colors = @{$hsh{colors}};
  1         4  
265             $_ = _color($_)
266 1         4 for @colors;
267 1         3316 i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
268             }
269 58         339 };
270              
271             $filters{nearest_color} =
272             {
273             callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
274             defaults => { },
275             callsub =>
276             sub {
277 1         4 my %hsh=@_;
278             # make sure the segments are specified with colors
279 1         1 my @colors;
280 1         2 for my $color (@{$hsh{colors}}) {
  1         3  
281 3 50       6 my $new_color = _color($color)
282             or die $Imager::ERRSTR."\n";
283 3         7 push @colors, $new_color;
284             }
285              
286             i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors,
287             $hsh{dist})
288 1 50       3198 or die Imager->_error_as_msg() . "\n";
289             },
290 58         359 };
291             $filters{gaussian} = {
292             callseq => [ 'image', 'stddev' ],
293             defaults => { },
294 2         6 callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
  2         95485  
295 58         368 };
296             $filters{gaussian2} = {
297             callseq => [ 'image', 'stddevX', 'stddevY' ],
298             defaults => { },
299 5         14 callsub => sub { my %hsh = @_; i_gaussian2($hsh{image}, $hsh{stddevX}, $hsh{stddevY}); },
  5         138512  
300 58         309 };
301             $filters{mosaic} =
302             {
303             callseq => [ qw(image size) ],
304             defaults => { size => 20 },
305 1         3 callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
  1         1668  
306 58         318 };
307             $filters{bumpmap} =
308             {
309             callseq => [ qw(image bump elevation lightx lighty st) ],
310             defaults => { elevation=>0, st=> 2 },
311             callsub => sub {
312 1         5 my %hsh = @_;
313             i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
314 1         5128 $hsh{lightx}, $hsh{lighty}, $hsh{st});
315             },
316 58         363 };
317             $filters{bumpmap_complex} =
318             {
319             callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
320             defaults => {
321             channel => 0,
322             tx => 0,
323             ty => 0,
324             Lx => 0.2,
325             Ly => 0.4,
326             Lz => -1.0,
327             cd => 1.0,
328             cs => 40,
329             n => 1.3,
330             Ia => [0,0,0],
331             Il => [255,255,255],
332             Is => [255,255,255],
333             },
334             callsub => sub {
335 1         6 my %hsh = @_;
336 1         5 for my $cname (qw/Ia Il Is/) {
337 3         5 my $old = $hsh{$cname};
338 3 50       7 my $new_color = _color($old)
339             or die $Imager::ERRSTR, "\n";
340 3         7 $hsh{$cname} = $new_color;
341             }
342             i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
343             $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
344             $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
345 1         7938 $hsh{Is});
346             },
347 58         716 };
348             $filters{postlevels} =
349             {
350             callseq => [ qw(image levels) ],
351             defaults => { levels => 10 },
352 1         3 callsub => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
  1         1749  
353 58         347 };
354             $filters{watermark} =
355             {
356             callseq => [ qw(image wmark tx ty pixdiff) ],
357             defaults => { pixdiff=>10, tx=>0, ty=>0 },
358             callsub =>
359             sub {
360 1         3 my %hsh = @_;
361             i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
362 1         2071 $hsh{pixdiff});
363             },
364 58         362 };
365             $filters{fountain} =
366             {
367             callseq => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
368             names => {
369             ftype => { linear => 0,
370             bilinear => 1,
371             radial => 2,
372             radial_square => 3,
373             revolution => 4,
374             conical => 5 },
375             repeat => { none => 0,
376             sawtooth => 1,
377             triangle => 2,
378             saw_both => 3,
379             tri_both => 4,
380             },
381             super_sample => {
382             none => 0,
383             grid => 1,
384             random => 2,
385             circle => 3,
386             },
387             combine => {
388             none => 0,
389             normal => 1,
390             multiply => 2, mult => 2,
391             dissolve => 3,
392             add => 4,
393             subtract => 5, 'sub' => 5,
394             diff => 6,
395             lighten => 7,
396             darken => 8,
397             hue => 9,
398             sat => 10,
399             value => 11,
400             color => 12,
401             },
402             },
403             defaults => { ftype => 0, repeat => 0, combine => 0,
404             super_sample => 0, ssample_param => 4,
405             segments=>[
406             [ 0, 0.5, 1,
407             [0,0,0],
408             [255, 255, 255],
409             0, 0,
410             ],
411             ],
412             },
413             callsub =>
414             sub {
415 10         31 my %hsh = @_;
416              
417             # make sure the segments are specified with colors
418 10         18 my @segments;
419 10         11 for my $segment (@{$hsh{segments}}) {
  10         16  
420 13         27 my @new_segment = @$segment;
421            
422 13   100     32 $_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
423 12         32 push @segments, \@new_segment;
424             }
425              
426             i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
427             $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
428 9 50       115550 $hsh{ssample_param}, \@segments)
429             or die Imager->_error_as_msg() . "\n";
430             },
431 58         1840 };
432             $filters{unsharpmask} =
433             {
434             callseq => [ qw(image stddev scale) ],
435             defaults => { stddev=>2.0, scale=>1.0 },
436             callsub =>
437             sub {
438 1         3 my %hsh = @_;
439 1         21227 i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
440             },
441 58         424 };
442              
443 58         229 $FORMATGUESS=\&def_guess_type;
444              
445 58         1195067 $warn_obsolete = 1;
446             }
447              
448             #
449             # Non methods
450             #
451              
452             # initialize Imager
453             # NOTE: this might be moved to an import override later on
454              
455             sub import {
456 98     98   971 my $i = 1;
457 98         419 while ($i < @_) {
458 34 50       114 if ($_[$i] eq '-log-stderr') {
459 0         0 init_log(undef, 4);
460 0         0 splice(@_, $i, 1);
461             }
462             else {
463 34         81 ++$i;
464             }
465             }
466 98         27860 goto &Exporter::import;
467             }
468              
469             sub init_log {
470 7     7 0 646 Imager->open_log(log => $_[0], level => $_[1]);
471             }
472              
473              
474             sub init {
475 8     8 0 686 my %parms=(loglevel=>1,@_);
476              
477 8 50       35 if (exists $parms{'warn_obsolete'}) {
478 0         0 $warn_obsolete = $parms{'warn_obsolete'};
479             }
480              
481 8 50       28 if ($parms{'log'}) {
482             Imager->open_log(log => $parms{log}, level => $parms{loglevel})
483 8 50       54 or return;
484             }
485              
486 8 50       31 if (exists $parms{'t1log'}) {
487 0 0       0 if ($formats{t1}) {
488 0 0       0 if (Imager::Font::T1::i_init_t1($parms{'t1log'})) {
489 0         0 Imager->_set_error(Imager->_error_as_msg);
490 0         0 return;
491             }
492             }
493             }
494              
495 8         25 return 1;
496             }
497              
498             {
499             my $is_logging = 0;
500              
501             sub open_log {
502 34     34 0 1726 my $class = shift;
503 34         205 my (%opts) = ( loglevel => 1, @_ );
504              
505 34         6850 $is_logging = i_init_log($opts{log}, $opts{loglevel});
506 34 50       200 unless ($is_logging) {
507 0         0 Imager->_set_error(Imager->_error_as_msg());
508 0         0 return;
509             }
510              
511 34         256 Imager->log("Imager $VERSION starting\n", 1);
512              
513 34         185 return $is_logging;
514             }
515              
516             sub close_log {
517 18     18 0 40131 i_init_log(undef, -1);
518 18         460 $is_logging = 0;
519             }
520              
521             sub log {
522 35     35 0 121 my ($class, $message, $level) = @_;
523              
524 35 100       108 defined $level or $level = 1;
525              
526 35         1293 i_log_entry($message, $level);
527             }
528              
529             sub is_logging {
530 0     0 0 0 return $is_logging;
531             }
532             }
533              
534             END {
535 58 50   58   91008 if ($DEBUG) {
536 0         0 print "shutdown code\n";
537             # for(keys %instances) { $instances{$_}->DESTROY(); }
538 0         0 malloc_state(); # how do decide if this should be used? -- store something from the import
539 0         0 print "Imager exiting\n";
540             }
541             }
542              
543             # Load a filter plugin
544              
545             our %DSOs;
546              
547             sub load_plugin {
548 0     0 0 0 my ($filename)=@_;
549 0         0 my $i;
550              
551 0 0       0 if ($^O eq 'android') {
552 0         0 require File::Spec;
553 0         0 $filename = File::Spec->rel2abs($filename);
554             }
555              
556 0         0 my ($DSO_handle,$str)=DSO_open($filename);
557 0 0       0 if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
  0         0  
  0         0  
558 0         0 my %funcs=DSO_funclist($DSO_handle);
559 0 0       0 if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf(" %2d: %s\n",$i++,$_); } }
  0         0  
  0         0  
  0         0  
  0         0  
560 0         0 $i=0;
561 0 0       0 for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
  0         0  
  0         0  
  0         0  
  0         0  
562              
563 0         0 $DSOs{$filename}=[$DSO_handle,\%funcs];
564              
565 0         0 for(keys %funcs) {
566 0         0 my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
567 0 0       0 $DEBUG && print "eval string:\n",$evstr,"\n";
568 0         0 eval $evstr;
569 0 0       0 print $@ if $@;
570             }
571 0         0 return 1;
572             }
573              
574             # Unload a plugin
575              
576             sub unload_plugin {
577 0     0 0 0 my ($filename)=@_;
578              
579 0 0       0 if ($^O eq 'android') {
580 0         0 require File::Spec;
581 0         0 $filename = File::Spec->rel2abs($filename);
582             }
583              
584 0 0       0 if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
  0         0  
  0         0  
585 0         0 my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
  0         0  
586 0         0 for(keys %{$funcref}) {
  0         0  
587 0         0 delete $filters{$_};
588 0 0       0 $DEBUG && print "unloading: $_\n";
589             }
590 0         0 my $rc=DSO_close($DSO_handle);
591 0 0       0 if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
  0         0  
  0         0  
592 0         0 return 1;
593             }
594              
595             # take the results of i_error() and make a message out of it
596             sub _error_as_msg {
597 178     178   218196 return join(": ", map $_->[0], i_errors());
598             }
599              
600             # this function tries to DWIM for color parameters
601             # color objects are used as is
602             # simple scalars are simply treated as single parameters to Imager::Color->new
603             # hashrefs are treated as named argument lists to Imager::Color->new
604             # arrayrefs are treated as list arguments to Imager::Color->new iff any
605             # parameter is > 1
606             # other arrayrefs are treated as list arguments to Imager::Color::Float
607              
608             sub _color {
609 1023     1023   1373 my $arg = shift;
610             # perl 5.6.0 seems to do weird things to $arg if we don't make an
611             # explicitly stringified copy
612             # I vaguely remember a bug on this on p5p, but couldn't find it
613             # through bugs.perl.org (I had trouble getting it to find any bugs)
614 1023         2195 my $copy = $arg . "";
615 1023         1164 my $result;
616              
617 1023 100       1638 if (ref $arg) {
618 659 100 100     1944 if (UNIVERSAL::isa($arg, "Imager::Color")
619             || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
620 520         673 $result = $arg;
621             }
622             else {
623 139 100       586 if ($copy =~ /^HASH\(/) {
    50          
624 3         14 $result = Imager::Color->new(%$arg);
625             }
626             elsif ($copy =~ /^ARRAY\(/) {
627 136         381 $result = Imager::Color->new(@$arg);
628             }
629             else {
630 0         0 $Imager::ERRSTR = "Not a color";
631             }
632             }
633             }
634             else {
635             # assume Imager::Color::new knows how to handle it
636 364         1415 $result = Imager::Color->new($arg);
637             }
638              
639 1023         2767 return $result;
640             }
641              
642             sub _combine {
643 123     123   366 my ($self, $combine, $default) = @_;
644              
645 123 100 100     471 if (!defined $combine && ref $self) {
646 55         107 $combine = $self->{combine};
647             }
648 123 100       272 defined $combine or $combine = $defaults{combine};
649 123 100       234 defined $combine or $combine = $default;
650              
651 123 100       304 if (exists $combine_types{$combine}) {
652 85         121 $combine = $combine_types{$combine};
653             }
654            
655 123         261 return $combine;
656             }
657              
658             sub _valid_image {
659 8601     8601   12562 my ($self, $method) = @_;
660              
661 8601 50       14294 ref $self
662             or return Imager->_set_error("$method needs an image object");
663              
664 8601 100 66     38478 $self->{IMG} && Scalar::Util::blessed($self->{IMG}) and return 1;
665              
666 68 50       180 my $msg = $self->{IMG} ? "images do not cross threads" : "empty input image";
667 68 50       206 $msg = "$method: $msg" if $method;
668 68         185 $self->_set_error($msg);
669              
670 68         531 return;
671             }
672              
673             # returns first defined parameter
674             sub _first {
675 76     76   119 for (@_) {
676 162 100       323 return $_ if defined $_;
677             }
678 1         3 return undef;
679             }
680              
681             #
682             # Methods to be called on objects.
683             #
684              
685             # Create a new Imager object takes very few parameters.
686             # usually you call this method and then call open from
687             # the resulting object
688              
689             sub new {
690 1272     1272 0 217888 my $class = shift;
691 1272         1976 my $self ={};
692 1272         2846 my %hsh=@_;
693 1272         2007 bless $self,$class;
694 1272         2529 $self->{IMG}=undef; # Just to indicate what exists
695 1272         1828 $self->{ERRSTR}=undef; #
696 1272         1868 $self->{DEBUG}=$DEBUG;
697 1272 50       2566 $self->{DEBUG} and print "Initialized Imager\n";
698 1272 100 100     13158 if (defined $hsh{file} ||
    100 66        
    50 66        
      33        
      66        
      66        
      66        
699             defined $hsh{fh} ||
700             defined $hsh{fd} ||
701             defined $hsh{callback} ||
702             defined $hsh{readcb} ||
703             defined $hsh{data} ||
704             defined $hsh{io}) {
705             # allow $img = Imager->new(file => $filename)
706 14         38 my %extras;
707            
708             # type is already used as a parameter to new(), rename it for the
709             # call to read()
710 14 100       41 if ($hsh{filetype}) {
711 6         14 $extras{type} = $hsh{filetype};
712             }
713 14 100       95 unless ($self->read(%hsh, %extras)) {
714 5         16 $Imager::ERRSTR = $self->{ERRSTR};
715 5         30 return;
716             }
717             }
718             elsif (defined $hsh{xsize} || defined $hsh{ysize}) {
719 554 100       1723 unless ($self->img_set(%hsh)) {
720 25         40 $Imager::ERRSTR = $self->{ERRSTR};
721 25         75 return;
722             }
723             }
724             elsif (%hsh) {
725 0         0 Imager->_set_error("new: supply xsize and ysize or a file access parameter or no parameters");
726 0         0 return;
727             }
728              
729 1242         3294 return $self;
730             }
731              
732             # Copy an entire image with no changes
733             # - if an image has magic the copy of it will not be magical
734              
735             sub copy {
736 217     217 0 21877 my $self = shift;
737              
738 217 100       411 $self->_valid_image("copy")
739             or return;
740              
741 216 100       512 unless (defined wantarray) {
742 1         3 my @caller = caller;
743 1         15 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
744 1         52 return;
745             }
746              
747 215         475 my $newcopy=Imager->new();
748 215         108181 $newcopy->{IMG} = i_copy($self->{IMG});
749 215         881 return $newcopy;
750             }
751              
752             # Paste a region
753              
754             sub paste {
755 29     29 0 463 my $self = shift;
756              
757 29 100       50 $self->_valid_image("paste")
758             or return;
759              
760 28         131 my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
761 28   100     79 my $src = $input{img} || $input{src};
762 28 100       49 unless($src) {
763 1         3 $self->_set_error("no source image");
764 1         4 return;
765             }
766 27 100       41 unless ($src->_valid_image("paste")) {
767 1         3 $self->{ERRSTR} = $src->{ERRSTR} . " (for src)";
768 1         4 return;
769             }
770 26 100       52 $input{left}=0 if $input{left} <= 0;
771 26 100       39 $input{top}=0 if $input{top} <= 0;
772              
773 26         1939 my($r,$b)=i_img_info($src->{IMG});
774 26         85 my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
775 26         34 my ($src_right, $src_bottom);
776 26 100       46 if ($input{src_coords}) {
777 1         2 ($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
  1         6  
778             }
779             else {
780 25 100       114 if (defined $input{src_maxx}) {
    100          
781 2         10 $src_right = $input{src_maxx};
782             }
783             elsif (defined $input{width}) {
784 1 50       4 if ($input{width} <= 0) {
785 0         0 $self->_set_error("paste: width must me positive");
786 0         0 return;
787             }
788 1         2 $src_right = $src_left + $input{width};
789             }
790             else {
791 22         29 $src_right = $r;
792             }
793 25 100       48 if (defined $input{src_maxy}) {
    100          
794 3         4 $src_bottom = $input{src_maxy};
795             }
796             elsif (defined $input{height}) {
797 1 50       3 if ($input{height} < 0) {
798 0         0 $self->_set_error("paste: height must be positive");
799 0         0 return;
800             }
801 1         2 $src_bottom = $src_top + $input{height};
802             }
803             else {
804 21         23 $src_bottom = $b;
805             }
806             }
807              
808 26 50       83 $src_right > $r and $src_right = $r;
809 26 50       49 $src_bottom > $b and $src_bottom = $b;
810              
811 26 50 33     76 if ($src_right <= $src_left
812             || $src_bottom < $src_top) {
813 0         0 $self->_set_error("nothing to paste");
814 0         0 return;
815             }
816              
817             i_copyto($self->{IMG}, $src->{IMG},
818             $src_left, $src_top, $src_right, $src_bottom,
819 26         5044 $input{left}, $input{top});
820              
821 26         185 return $self; # What should go here??
822             }
823              
824             # Crop an image - i.e. return a new image that is smaller
825              
826             sub crop {
827 47     47 0 4164 my $self=shift;
828              
829 47 100       96 $self->_valid_image("crop")
830             or return;
831            
832 46 100       89 unless (defined wantarray) {
833 1         4 my @caller = caller;
834 1         13 warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
835 1         48 return;
836             }
837              
838 45         114 my %hsh=@_;
839              
840             my ($w, $h, $l, $r, $b, $t) =
841 45         114 @hsh{qw(width height left right bottom top)};
842              
843             # work through the various possibilities
844 45 100       85 if (defined $l) {
    100          
    100          
845 33 100       110 if (defined $w) {
    100          
846 1         2 $r = $l + $w;
847             }
848             elsif (!defined $r) {
849 1         3 $r = $self->getwidth;
850             }
851             }
852             elsif (defined $r) {
853 3 100       5 if (defined $w) {
854 2         3 $l = $r - $w;
855             }
856             else {
857 1         2 $l = 0;
858             }
859             }
860             elsif (defined $w) {
861 1         3 $l = int(0.5+($self->getwidth()-$w)/2);
862 1         2 $r = $l + $w;
863             }
864             else {
865 8         9 $l = 0;
866 8         17 $r = $self->getwidth;
867             }
868 45 100       81 if (defined $t) {
    100          
    100          
869 35 100       62 if (defined $h) {
    100          
870 4         5 $b = $t + $h;
871             }
872             elsif (!defined $b) {
873 1         4 $b = $self->getheight;
874             }
875             }
876             elsif (defined $b) {
877 3 100       6 if (defined $h) {
878 2         4 $t = $b - $h;
879             }
880             else {
881 1         1 $t = 0;
882             }
883             }
884             elsif (defined $h) {
885 1         3 $t=int(0.5+($self->getheight()-$h)/2);
886 1         2 $b=$t+$h;
887             }
888             else {
889 6         8 $t = 0;
890 6         10 $b = $self->getheight;
891             }
892              
893 45 50       76 ($l,$r)=($r,$l) if $l>$r;
894 45 50       65 ($t,$b)=($b,$t) if $t>$b;
895              
896 45 100       67 $l < 0 and $l = 0;
897 45 100       78 $r > $self->getwidth and $r = $self->getwidth;
898 45 100       104 $t < 0 and $t = 0;
899 45 100       64 $b > $self->getheight and $b = $self->getheight;
900              
901 45 100 100     120 if ($l == $r || $t == $b) {
902 2         7 $self->_set_error("resulting image would have no content");
903 2         9 return;
904             }
905 43 100 100     110 if( $r < $l or $b < $t ) {
906 2         6 $self->_set_error("attempting to crop outside of the image");
907 2         8 return;
908             }
909 41         99 my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
910              
911 41         7543 i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
912 41         203 return $dst;
913             }
914              
915             my $empty_trim_colors = Imager::TrimColorList->new();
916              
917             sub _trim_rect {
918 12     12   23 my ($self, $name, %hsh) = @_;
919              
920 12 50       23 $self->_valid_image($name)
921             or return;
922              
923 12         20 my $auto = delete $hsh{auto};
924 12   66     29 my $colors = delete $hsh{colors} || $empty_trim_colors;
925 12   50     28 my $alpha = delete $hsh{alpha} || 0;
926 12         13 my $tolerance = delete $hsh{tolerance};
927 12 50       28 defined $tolerance or $tolerance = 0.01;
928              
929 12 50       38 if (keys %hsh) {
930 0         0 $self->_set_error("$name: unexpected arguments:".join(", ", sort keys %hsh));
931 0         0 return;
932             }
933              
934 12 100       18 if ($auto) {
935 5 50       11 if ($colors != $empty_trim_colors) {
936 0         0 $self->_set_error("$name: only one of auto and colors can be supplied");
937 0         0 return;
938             }
939 5 50       22 if ($tolerance < 0) {
940 0         0 $self->_set_error("$name: tolerance must be non-negative");
941 0         0 return;
942             }
943              
944 5         14 $colors = Imager::TrimColorList->auto
945             (
946             auto => $auto,
947             tolerance => $tolerance,
948             name => $name,
949             image => $self,
950             );
951 5 50       10 unless ($colors) {
952 0         0 $self->_set_error(Imager->errstr);
953 0         0 return;
954             }
955             }
956              
957 12 50       25 unless (ref $colors) {
958 0         0 $self->_set_error("$name: colors must be an arrayref or an Imager::TrimColorList object");
959 0         0 return;
960             }
961 12 100       26 unless (UNIVERSAL::isa($colors, "Imager::TrimColorList")) {
962 5 50       14 unless (Scalar::Util::reftype($colors) eq "ARRAY") {
963 0         0 $self->_set_error("$name: colors must be an arrayref or an Imager::TrimColorList object");
964 0         0 return;
965             }
966 5         15 $colors = Imager::TrimColorList->new(@$colors);
967             }
968              
969 12         262 return i_trim_rect($self->{IMG}, $alpha, $colors);
970             }
971              
972             sub trim_rect {
973 8     8 0 36 my ($self, %hsh) = @_;
974              
975 8         22 return $self->_trim_rect("trim_rect", %hsh);
976             }
977              
978             sub trim {
979 4     4 0 2252 my ($self, %hsh) = @_;
980              
981 4 50       26 my ($left, $top, $right, $bottom) = $self->_trim_rect("trim", %hsh)
982             or return;
983              
984 4 50       27 if ($left == $self->getwidth) {
985             # the whole image would be trimmed, but we don't support zero
986             # width or height images.
987 0         0 return $self->crop(width => 1, height => 1);
988             }
989             else {
990 4         14 my ($w, $h) = i_img_info($self->{IMG});
991 4         11 return $self->crop(left => $left, right => $w - $right,
992             top => $top, bottom => $h - $bottom);
993             }
994             }
995              
996             sub _sametype {
997 41     41   85 my ($self, %opts) = @_;
998              
999 41 50       59 $self->_valid_image
1000             or return;
1001              
1002 41   33     85 my $x = $opts{xsize} || $self->getwidth;
1003 41   33     69 my $y = $opts{ysize} || $self->getheight;
1004 41   33     88 my $channels = $opts{channels} || $self->getchannels;
1005            
1006 41         85 my $out = Imager->new;
1007 41 50       66 if ($channels == $self->getchannels) {
1008 41         3490 $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
1009             }
1010             else {
1011 0         0 $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
1012             }
1013 41 50       129 unless ($out->{IMG}) {
1014 0         0 $self->{ERRSTR} = $self->_error_as_msg;
1015 0         0 return;
1016             }
1017            
1018 41         99 return $out;
1019             }
1020              
1021             # Sets an image to a certain size and channel number
1022             # if there was previously data in the image it is discarded
1023              
1024             my %model_channels =
1025             (
1026             gray => 1,
1027             graya => 2,
1028             rgb => 3,
1029             rgba => 4,
1030             );
1031              
1032             sub img_set {
1033 554     554 0 750 my $self=shift;
1034              
1035 554         1903 my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
1036              
1037 554         847 undef($self->{IMG});
1038              
1039 554 100       1156 if ($hsh{model}) {
1040 4 50       10 if (my $channels = $model_channels{$hsh{model}}) {
1041 4         7 $hsh{channels} = $channels;
1042             }
1043             else {
1044 0         0 $self->_set_error("new: unknown value for model '$hsh{model}'");
1045 0         0 return;
1046             }
1047             }
1048              
1049 554 100 100     2586 if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
    100          
    100          
1050             $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
1051 25   50     2087 $hsh{maxcolors} || 256);
1052             }
1053             elsif ($hsh{bits} eq 'double') {
1054 70         8835 $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
1055             }
1056             elsif ($hsh{bits} == 16) {
1057 22         2519 $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
1058             }
1059             else {
1060             $self->{IMG}= i_img_8_new($hsh{'xsize'}, $hsh{'ysize'},
1061 437         41665 $hsh{'channels'});
1062             }
1063              
1064 554 100       2116 unless ($self->{IMG}) {
1065 25         90 $self->_set_error(Imager->_error_as_msg());
1066 25         87 return;
1067             }
1068              
1069 529         1695 $self;
1070             }
1071              
1072             # created a masked version of the current image
1073             sub masked {
1074 10     10 0 685 my $self = shift;
1075              
1076 10 100       26 $self->_valid_image("masked")
1077             or return;
1078              
1079 9         26 my %opts = (left => 0,
1080             top => 0,
1081             right => $self->getwidth,
1082             bottom => $self->getheight,
1083             @_);
1084 9 100       27 my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
1085              
1086 9         26 my $result = Imager->new;
1087             $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
1088             $opts{top}, $opts{right} - $opts{left},
1089 9         772 $opts{bottom} - $opts{top});
1090 9 100       37 unless ($result->{IMG}) {
1091 1         5 $self->_set_error(Imager->_error_as_msg);
1092 1         3 return;
1093             }
1094              
1095             # keep references to the mask and base images so they don't
1096             # disappear on us
1097 8         22 $result->{DEPENDS} = [ $self->{IMG}, $mask ];
1098              
1099 8         33 return $result;
1100             }
1101              
1102             # convert an RGB image into a paletted image
1103             sub to_paletted {
1104 14     14 0 742 my $self = shift;
1105 14         22 my $opts;
1106 14 100 66     68 if (@_ != 1 && !ref $_[0]) {
1107 13         38 $opts = { @_ };
1108             }
1109             else {
1110 1         4 $opts = shift;
1111             }
1112              
1113 14 100       38 unless (defined wantarray) {
1114 1         4 my @caller = caller;
1115 1         8 warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
1116 1         45 return;
1117             }
1118              
1119 13 100       33 $self->_valid_image("to_paletted")
1120             or return;
1121              
1122 12         34 my $result = Imager->new;
1123 12 100       92638 unless ($result->{IMG} = i_img_to_pal($self->{IMG}, $opts)) {
1124 2         13 $self->_set_error(Imager->_error_as_msg);
1125 2         6 return;
1126             }
1127              
1128 10         63 return $result;
1129             }
1130              
1131             sub make_palette {
1132 7     7 0 921 my ($class, $quant, @images) = @_;
1133              
1134 7 100       18 unless (@images) {
1135 1         5 Imager->_set_error("make_palette: supply at least one image");
1136 1         2 return;
1137             }
1138 6         10 my $index = 1;
1139 6         12 for my $img (@images) {
1140 7 100       15 unless ($img->{IMG}) {
1141 1         7 Imager->_set_error("make_palette: image $index is empty");
1142 1         3 return;
1143             }
1144 6         10 ++$index;
1145             }
1146              
1147 5         6521 my @cols = i_img_make_palette($quant, map $_->{IMG}, @images);
1148 5 100       24 unless (@cols) {
1149 1         16 Imager->_set_error(Imager->_error_as_msg);
1150 1         5 return;
1151             }
1152 4         30 return @cols;
1153             }
1154              
1155             # convert a paletted (or any image) to an 8-bit/channel RGB image
1156             sub to_rgb8 {
1157 3     3 0 254 my $self = shift;
1158              
1159 3 100       7 unless (defined wantarray) {
1160 1         5 my @caller = caller;
1161 1         12 warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
1162 1         46 return;
1163             }
1164              
1165 2 100       4 $self->_valid_image("to_rgb8")
1166             or return;
1167              
1168 1         3 my $result = Imager->new;
1169 1 50       1012 unless ($result->{IMG} = i_img_to_rgb($self->{IMG})) {
1170 0         0 $self->_set_error(Imager->_error_as_msg());
1171 0         0 return;
1172             }
1173              
1174 1         4 return $result;
1175             }
1176              
1177             # convert a paletted (or any image) to a 16-bit/channel RGB image
1178             sub to_rgb16 {
1179 8     8 0 893 my $self = shift;
1180              
1181 8 50       26 unless (defined wantarray) {
1182 0         0 my @caller = caller;
1183 0         0 warn "to_rgb16() called in void context - to_rgb16() returns the converted image at $caller[1] line $caller[2]\n";
1184 0         0 return;
1185             }
1186              
1187 8 100       20 $self->_valid_image("to_rgb16")
1188             or return;
1189              
1190 7         34 my $result = Imager->new;
1191 7 50       5261 unless ($result->{IMG} = i_img_to_rgb16($self->{IMG})) {
1192 0         0 $self->_set_error(Imager->_error_as_msg());
1193 0         0 return;
1194             }
1195              
1196 7         35 return $result;
1197             }
1198              
1199             # convert a paletted (or any image) to an double/channel RGB image
1200             sub to_rgb_double {
1201 3     3 0 275 my $self = shift;
1202              
1203 3 50       10 unless (defined wantarray) {
1204 0         0 my @caller = caller;
1205 0         0 warn "to_rgb16() called in void context - to_rgb_double() returns the converted image at $caller[1] line $caller[2]\n";
1206 0         0 return;
1207             }
1208              
1209 3 100       7 $self->_valid_image("to_rgb_double")
1210             or return;
1211              
1212 2         7 my $result = Imager->new;
1213 2 50       1463 unless ($result->{IMG} = i_img_to_drgb($self->{IMG})) {
1214 0         0 $self->_set_error(Imager->_error_as_msg());
1215 0         0 return;
1216             }
1217              
1218 2         10 return $result;
1219             }
1220              
1221             sub addcolors {
1222 24     24 0 1020 my $self = shift;
1223 24         74 my %opts = (colors=>[], @_);
1224              
1225 24 100       85 $self->_valid_image("addcolors")
1226             or return -1;
1227              
1228 23 50       42 my @colors = @{$opts{colors}}
  23         68  
1229             or return undef;
1230              
1231 23         48 for my $color (@colors) {
1232 49         85 $color = _color($color);
1233 49 100       108 unless ($color) {
1234 1         3 $self->_set_error($Imager::ERRSTR);
1235 1         5 return;
1236             }
1237             }
1238              
1239 22         2109 return i_addcolors($self->{IMG}, @colors);
1240             }
1241              
1242             sub setcolors {
1243 12     12 0 508 my $self = shift;
1244 12         34 my %opts = (start=>0, colors=>[], @_);
1245              
1246 12 100       27 $self->_valid_image("setcolors")
1247             or return;
1248              
1249 11 100       42 my @colors = @{$opts{colors}}
  11         38  
1250             or return undef;
1251              
1252 10         14 for my $color (@colors) {
1253 14         23 $color = _color($color);
1254 14 100       27 unless ($color) {
1255 1         3 $self->_set_error($Imager::ERRSTR);
1256 1         4 return;
1257             }
1258             }
1259              
1260 9         673 return i_setcolors($self->{IMG}, $opts{start}, @colors);
1261             }
1262              
1263             sub getcolors {
1264 15     15 0 2866 my $self = shift;
1265 15         31 my %opts = @_;
1266              
1267 15 100       44 $self->_valid_image("getcolors")
1268             or return;
1269              
1270 14 100 66     64 if (!exists $opts{start} && !exists $opts{count}) {
    50          
    0          
1271             # get them all
1272 9         17 $opts{start} = 0;
1273 9         21 $opts{count} = $self->colorcount;
1274             }
1275             elsif (!exists $opts{count}) {
1276 5         11 $opts{count} = 1;
1277             }
1278             elsif (!exists $opts{start}) {
1279 0         0 $opts{start} = 0;
1280             }
1281              
1282 14         4437 return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
1283             }
1284              
1285             sub colorcount {
1286 15     15 0 1049 my ($self) = @_;
1287              
1288 15 100       28 $self->_valid_image("colorcount")
1289             or return -1;
1290              
1291 14         75 return i_colorcount($self->{IMG});
1292             }
1293              
1294             sub maxcolors {
1295 3     3 0 9 my $self = shift;
1296              
1297 3 100       8 $self->_valid_image("maxcolors")
1298             or return -1;
1299              
1300 2         14 i_maxcolors($self->{IMG});
1301             }
1302              
1303             sub findcolor {
1304 9     9 0 482 my $self = shift;
1305 9         21 my %opts = @_;
1306              
1307 9 100       19 $self->_valid_image("findcolor")
1308             or return;
1309              
1310 8 50       22 unless ($opts{color}) {
1311 0         0 $self->_set_error("findcolor: no color parameter");
1312 0         0 return;
1313             }
1314              
1315             my $color = _color($opts{color})
1316 8 50       15 or return;
1317              
1318 8         87 return i_findcolor($self->{IMG}, $color);
1319             }
1320              
1321             sub bits {
1322 53     53 0 1330 my $self = shift;
1323              
1324 53 100       103 $self->_valid_image("bits")
1325             or return;
1326              
1327 52         243 my $bits = i_img_bits($self->{IMG});
1328 52 100 66     186 if ($bits && $bits == length(pack("d", 1)) * 8) {
1329 12         23 $bits = 'double';
1330             }
1331 52         203 return $bits;
1332             }
1333              
1334             sub type {
1335 57     57 0 16338 my $self = shift;
1336              
1337 57 100       123 $self->_valid_image("type")
1338             or return;
1339              
1340 56 100       421 return i_img_type($self->{IMG}) ? "paletted" : "direct";
1341             }
1342              
1343             sub virtual {
1344 2     2 0 5 my $self = shift;
1345              
1346 2 100       5 $self->_valid_image("virtual")
1347             or return;
1348              
1349 1         6 return i_img_virtual($self->{IMG});
1350             }
1351              
1352             sub is_bilevel {
1353 25     25 0 53 my ($self) = @_;
1354              
1355 25 100       50 $self->_valid_image("is_bilevel")
1356             or return;
1357              
1358 24         159 return i_img_is_monochrome($self->{IMG});
1359             }
1360              
1361             sub tags {
1362 86     86 0 1748 my ($self, %opts) = @_;
1363              
1364 86 100       180 $self->_valid_image("tags")
1365             or return;
1366              
1367 85 50       187 if (defined $opts{name}) {
    0          
1368 85         103 my @result;
1369 85         122 my $start = 0;
1370 85         91 my $found;
1371 85         394 while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1372 85         311 push @result, (i_tags_get($self->{IMG}, $found))[1];
1373 85         238 $start = $found+1;
1374             }
1375 85 100       372 return wantarray ? @result : $result[0];
1376             }
1377             elsif (defined $opts{code}) {
1378 0         0 my @result;
1379 0         0 my $start = 0;
1380 0         0 my $found;
1381 0         0 while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1382 0         0 push @result, (i_tags_get($self->{IMG}, $found))[1];
1383 0         0 $start = $found+1;
1384             }
1385 0         0 return @result;
1386             }
1387             else {
1388 0 0       0 if (wantarray) {
1389 0         0 return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
  0         0  
1390             }
1391             else {
1392 0         0 return i_tags_count($self->{IMG});
1393             }
1394             }
1395             }
1396              
1397             sub addtag {
1398 23     23 0 1378 my $self = shift;
1399 23         63 my %opts = @_;
1400              
1401 23 100       54 $self->_valid_image("addtag")
1402             or return;
1403              
1404 22 100       71 if ($opts{name}) {
    50          
1405 20 50       51 if (defined $opts{value}) {
    0          
1406 20 100       118 if ($opts{value} =~ /^\d+$/) {
1407             # add as a number
1408 17         1075 return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1409             }
1410             else {
1411 3         390 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1412             }
1413             }
1414             elsif (defined $opts{data}) {
1415             # force addition as a string
1416 0         0 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1417             }
1418             else {
1419 0         0 $self->{ERRSTR} = "No value supplied";
1420 0         0 return undef;
1421             }
1422             }
1423             elsif ($opts{code}) {
1424 2 50       130 warnings::warnif("Imager::tagcodes", "addtag: code parameter is deprecated")
1425             if $] >= 5.014;
1426 2 50       47 if (defined $opts{value}) {
    0          
1427 2 50       12 if ($opts{value} =~ /^\d+$/) {
1428             # add as a number
1429 2         101 return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1430             }
1431             else {
1432 0         0 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1433             }
1434             }
1435             elsif (defined $opts{data}) {
1436             # force addition as a string
1437 0         0 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1438             }
1439             else {
1440 0         0 $self->{ERRSTR} = "No value supplied";
1441 0         0 return undef;
1442             }
1443             }
1444             else {
1445 0         0 return undef;
1446             }
1447             }
1448              
1449             sub deltag {
1450 21     21 0 37 my $self = shift;
1451 21         51 my %opts = @_;
1452              
1453 21 100       50 $self->_valid_image("deltag")
1454             or return 0;
1455              
1456 20 50       78 if (defined $opts{'index'}) {
    50          
    0          
1457 0         0 return i_tags_delete($self->{IMG}, $opts{'index'});
1458             }
1459             elsif (defined $opts{name}) {
1460 20         247 return i_tags_delbyname($self->{IMG}, $opts{name});
1461             }
1462             elsif (defined $opts{code}) {
1463 0 0       0 warnings::warnif("Imager::tagcodes", "deltag: code parameter is deprecated")
1464             if $] >= 5.014;
1465 0         0 return i_tags_delbycode($self->{IMG}, $opts{code});
1466             }
1467             else {
1468 0         0 $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1469 0         0 return 0;
1470             }
1471             }
1472              
1473             sub settag {
1474 23     23 0 1042 my ($self, %opts) = @_;
1475              
1476 23 100       65 $self->_valid_image("settag")
1477             or return;
1478              
1479 22 100       65 if ($opts{name}) {
    50          
1480 20         74 $self->deltag(name=>$opts{name});
1481 20         79 return $self->addtag(name=>$opts{name}, value=>$opts{value});
1482             }
1483             elsif (defined $opts{code}) {
1484 2 50       229 warnings::warnif("Imager::tagcodes", "settag: code parameter is deprecated")
1485             if $] >= 5.014;
1486 2         79 i_tags_delbycode($self->{IMG}, $opts{code});
1487 2 50       6 if (defined $opts{value}) {
    0          
1488 2 50       10 if ($opts{value} =~ /^\d+$/) {
1489             # add as a number
1490 2         110 return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1491             }
1492             else {
1493 0         0 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1494             }
1495             }
1496             elsif (defined $opts{data}) {
1497             # force addition as a string
1498 0         0 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1499             }
1500             else {
1501 0         0 $self->{ERRSTR} = "No value supplied";
1502 0         0 return undef;
1503             }
1504             }
1505             else {
1506 0         0 return undef;
1507             }
1508             }
1509              
1510              
1511             sub _get_reader_io {
1512 226     226   441 my ($self, $input) = @_;
1513              
1514 226 50 33     1143 if ($input->{io}) {
    100          
    100          
    100          
    100          
    50          
1515 0         0 return $input->{io}, undef;
1516             }
1517             elsif ($input->{fd}) {
1518 4         352 return io_new_fd($input->{fd});
1519             }
1520             elsif ($input->{fh}) {
1521 11 50       43 unless (Scalar::Util::openhandle($input->{fh})) {
1522 0         0 $self->_set_error("Handle in fh option not opened");
1523 0         0 return;
1524             }
1525 11         45 return Imager::IO->new_fh($input->{fh});
1526             }
1527             elsif ($input->{file}) {
1528 140         200 my $file;
1529 140 50       5888 unless (open $file, "<", $input->{file}) {
1530 0         0 $self->_set_error("Could not open $input->{file}: $!");
1531 0         0 return;
1532             }
1533 140         569 binmode $file;
1534 140         12191 return (io_new_fd(fileno($file)), $file);
1535             }
1536             elsif ($input->{data}) {
1537 63         5849 return io_new_buffer($input->{data});
1538             }
1539             elsif ($input->{callback} || $input->{readcb}) {
1540 8 50       20 if (!$input->{seekcb}) {
1541 0         0 $self->_set_error("Need a seekcb parameter");
1542             }
1543 8 50       18 if ($input->{maxbuffer}) {
1544             return io_new_cb($input->{writecb},
1545             $input->{callback} || $input->{readcb},
1546             $input->{seekcb}, $input->{closecb},
1547 0   0     0 $input->{maxbuffer});
1548             }
1549             else {
1550             return io_new_cb($input->{writecb},
1551             $input->{callback} || $input->{readcb},
1552 8   33     1091 $input->{seekcb}, $input->{closecb});
1553             }
1554             }
1555             else {
1556 0         0 $self->_set_error("file/fd/fh/data/callback parameter missing");
1557 0         0 return;
1558             }
1559             }
1560              
1561             sub _get_writer_io {
1562 168     168   347 my ($self, $input) = @_;
1563              
1564 168 100       439 my $buffered = exists $input->{buffered} ? $input->{buffered} : 1;
1565              
1566 168         277 my $io;
1567             my @extras;
1568 168 100 66     750 if ($input->{io}) {
    50          
    100          
    100          
    100          
    50          
1569 19         42 $io = $input->{io};
1570             }
1571             elsif ($input->{fd}) {
1572 0         0 $io = io_new_fd($input->{fd});
1573             }
1574             elsif ($input->{fh}) {
1575 6 50       27 unless (Scalar::Util::openhandle($input->{fh})) {
1576 0         0 $self->_set_error("Handle in fh option not opened");
1577 0         0 return;
1578             }
1579 6         35 $io = Imager::IO->new_fh($input->{fh});
1580             }
1581             elsif ($input->{file}) {
1582 113         146 my $fh;
1583 113 50       10003 unless (open $fh, "+>", $input->{file}) {
1584 0         0 $self->_set_error("Could not open file $input->{file}: $!");
1585 0         0 return;
1586             }
1587 113 50       611 binmode($fh) or die;
1588 113         9770 $io = io_new_fd(fileno($fh));
1589 113         468 push @extras, $fh;
1590             }
1591             elsif ($input->{data}) {
1592 20         2240 $io = io_new_bufchain();
1593             }
1594             elsif ($input->{callback} || $input->{writecb}) {
1595 10 100 66     41 if ($input->{maxbuffer} && $input->{maxbuffer} == 1) {
1596 4         7 $buffered = 0;
1597             }
1598             $io = io_new_cb($input->{callback} || $input->{writecb},
1599             $input->{readcb},
1600 10   66     1362 $input->{seekcb}, $input->{closecb});
1601             }
1602             else {
1603 0         0 $self->_set_error("file/fd/fh/data/callback parameter missing");
1604 0         0 return;
1605             }
1606              
1607 168 100       481 unless ($buffered) {
1608 5         27 $io->set_buffered(0);
1609             }
1610              
1611 168         661 return ($io, @extras);
1612             }
1613              
1614             sub _test_format {
1615 152     152   15323 my ($io) = @_;
1616              
1617 152         7778 return i_test_format_probe($io, -1);
1618             }
1619              
1620             sub add_file_magic {
1621 1     1 0 577 my ($class, %opts) = @_;
1622              
1623 1         5 my $name = delete $opts{name};
1624 1         2 my $bits = delete $opts{bits};
1625 1         2 my $mask = delete $opts{mask};
1626              
1627 1 50       9 unless (i_add_file_magic($name, $bits, $mask)) {
1628 0         0 Imager->_set_error(Imager->_error_as_msg);
1629 0         0 return;
1630             }
1631              
1632 1         5 1;
1633             }
1634              
1635             # Read an image from file
1636              
1637             sub read {
1638 221     221 0 15911 my $self = shift;
1639 221         687 my %input=@_;
1640              
1641 221 100       561 if (defined($self->{IMG})) {
1642             # let IIM_DESTROY do the destruction, since the image may be
1643             # referenced from elsewhere
1644             #i_img_destroy($self->{IMG});
1645 22         5943 undef($self->{IMG});
1646             }
1647              
1648 221 50       779 my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1649              
1650 221         666 my $type = $input{'type'};
1651 221 100       1029 unless ($type) {
1652 116         303 $type = _test_format($IO);
1653             }
1654              
1655 221 100 100     1047 if ($input{file} && !$type) {
1656             # guess the type
1657 1         3 $type = $FORMATGUESS->($input{file});
1658             }
1659              
1660 221 100       475 unless ($type) {
1661 2         8 my $msg = "type parameter missing and it couldn't be determined from the file contents";
1662 2 100       8 $input{file} and $msg .= " or file name";
1663 2         6 $self->_set_error($msg);
1664 2         206 return undef;
1665             }
1666              
1667 219         654 _reader_autoload($type);
1668              
1669 219 0 33     532 if ($readers{$type} && $readers{$type}{single}) {
1670 0         0 return $readers{$type}{single}->($self, $IO, %input);
1671             }
1672              
1673 219 100       475 unless ($formats_low{$type}) {
1674 6         34 my $read_types = join ', ', sort Imager->read_types();
1675 6         70 $self->_set_error("format '$type' not supported - formats $read_types available for reading - $reader_load_errors{$type}");
1676 6         427 return;
1677             }
1678              
1679 213         330 my $allow_incomplete = $input{allow_incomplete};
1680 213 100       419 defined $allow_incomplete or $allow_incomplete = 0;
1681              
1682 213 100       480 if ( $type eq 'pnm' ) {
1683 75         44178 $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
1684 75 100       2909 if ( !defined($self->{IMG}) ) {
1685 20         53 $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1686 20         1789 return undef;
1687             }
1688 55 50       165 $self->{DEBUG} && print "loading a pnm file\n";
1689 55         5371 return $self;
1690             }
1691              
1692 138 100       283 if ( $type eq 'bmp' ) {
1693 98         50451 $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
1694 98 100       1429 if ( !defined($self->{IMG}) ) {
1695 46         129 $self->{ERRSTR}=$self->_error_as_msg();
1696 46         5197 return undef;
1697             }
1698 52 50       141 $self->{DEBUG} && print "loading a bmp file\n";
1699             }
1700              
1701 92 100       229 if ( $type eq 'tga' ) {
1702 22         33737 $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1703 22 100       2928 if ( !defined($self->{IMG}) ) {
1704 4         16 $self->{ERRSTR}=$self->_error_as_msg();
1705 4         395 return undef;
1706             }
1707 18 50       60 $self->{DEBUG} && print "loading a tga file\n";
1708             }
1709              
1710 88 100       194 if ( $type eq 'raw' ) {
1711 18 50 33     71 unless ( $input{xsize} && $input{ysize} ) {
1712 0         0 $self->_set_error('missing xsize or ysize parameter for raw');
1713 0         0 return undef;
1714             }
1715              
1716 18         61 my $interleave = _first($input{raw_interleave}, $input{interleave});
1717 18 100       46 unless (defined $interleave) {
1718 1         42 my @caller = caller;
1719 1         16 warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
1720 1         8 $interleave = 1;
1721             }
1722 18         52 my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
1723 18         56 my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
1724              
1725             $self->{IMG} = i_readraw_wiol( $IO,
1726             $input{xsize},
1727             $input{ysize},
1728 18         5503 $data_ch,
1729             $store_ch,
1730             $interleave);
1731 18 100       416 if ( !defined($self->{IMG}) ) {
1732 4         12 $self->{ERRSTR}=$self->_error_as_msg();
1733 4         399 return undef;
1734             }
1735 14 50       42 $self->{DEBUG} && print "loading a raw file\n";
1736             }
1737              
1738 84         8611 return $self;
1739             }
1740              
1741             sub register_reader {
1742 3     3 0 13 my ($class, %opts) = @_;
1743              
1744             defined $opts{type}
1745 3 50       8 or die "register_reader called with no type parameter\n";
1746              
1747 3         5 my $type = $opts{type};
1748              
1749             defined $opts{single} || defined $opts{multiple}
1750 3 50 33     7 or die "register_reader called with no single or multiple parameter\n";
1751              
1752 3         8 $readers{$type} = { };
1753 3 50       8 if ($opts{single}) {
1754 3         6 $readers{$type}{single} = $opts{single};
1755             }
1756 3 100       6 if ($opts{multiple}) {
1757 2         4 $readers{$type}{multiple} = $opts{multiple};
1758             }
1759              
1760 3         6 return 1;
1761             }
1762              
1763             sub register_writer {
1764 3     3 0 8 my ($class, %opts) = @_;
1765              
1766             defined $opts{type}
1767 3 50       7 or die "register_writer called with no type parameter\n";
1768              
1769 3         4 my $type = $opts{type};
1770              
1771             defined $opts{single} || defined $opts{multiple}
1772 3 50 33     7 or die "register_writer called with no single or multiple parameter\n";
1773              
1774 3         6 $writers{$type} = { };
1775 3 50       4 if ($opts{single}) {
1776 3         5 $writers{$type}{single} = $opts{single};
1777             }
1778 3 100       7 if ($opts{multiple}) {
1779 2         3 $writers{$type}{multiple} = $opts{multiple};
1780             }
1781              
1782 3         10 return 1;
1783             }
1784              
1785             sub read_types {
1786             my %types =
1787             (
1788 96         211 map { $_ => 1 }
1789             keys %readers,
1790 16     16 0 148 grep($file_formats{$_}, keys %formats),
1791             qw(ico sgi), # formats not handled directly, but supplied with Imager
1792             );
1793              
1794 16         150 return keys %types;
1795             }
1796              
1797             sub write_types {
1798             my %types =
1799             (
1800 96         177 map { $_ => 1 }
1801             keys %writers,
1802 16     16 0 72 grep($file_formats{$_}, keys %formats),
1803             qw(ico sgi), # formats not handled directly, but supplied with Imager
1804             );
1805              
1806 16         130 return keys %types;
1807             }
1808              
1809             sub _load_file {
1810 105     105   176 my ($file, $error) = @_;
1811              
1812 105 100       188 if ($attempted_to_load{$file}) {
1813 22 50       56 if ($file_load_errors{$file}) {
1814 22         32 $$error = $file_load_errors{$file};
1815 22         61 return 0;
1816             }
1817             else {
1818 0         0 return 1;
1819             }
1820             }
1821             else {
1822 83         227 local $SIG{__DIE__};
1823 83         123 my $loaded = eval {
1824 83         742 local @INC = @INC;
1825 83 100       189 pop @INC if $INC[-1] eq '.';
1826 83         196 ++$attempted_to_load{$file};
1827 83         9558 require $file;
1828 0         0 return 1;
1829             };
1830 83 50       446 if ($loaded) {
1831 0         0 return 1;
1832             }
1833             else {
1834 83   50     175 my $work = $@ || "Unknown error";
1835 83         130 chomp $work;
1836 83         188 $work =~ s/\n?Compilation failed in require at .*Imager\.pm line .*\z//m;
1837 83         110 $work =~ s/\n/\\n/g;
1838 83         6044 $work =~ s/\s*\.?\z/ loading $file/;
1839 83         249 $file_load_errors{$file} = $work;
1840 83         169 $$error = $work;
1841 83         304 return 0;
1842             }
1843             }
1844             }
1845              
1846             # probes for an Imager::File::whatever module
1847             sub _reader_autoload {
1848 222     222   428 my $type = shift;
1849              
1850 222 100 66     745 return if $formats_low{$type} || $readers{$type};
1851              
1852 8 50       57 return unless $type =~ /^\w+$/;
1853              
1854 8         40 my $file = "Imager/File/\U$type\E.pm";
1855              
1856 8         12 my $error;
1857 8         25 my $loaded = _load_file($file, \$error);
1858 8 100 66     51 if (!$loaded && $error =~ /^Can't locate /) {
1859 7         24 my $filer = "Imager/File/\U$type\EReader.pm";
1860 7         19 $loaded = _load_file($filer, \$error);
1861 7 50       33 if ($error =~ /^Can't locate /) {
1862 7         25 $error = "Can't locate $file or $filer";
1863             }
1864             }
1865 8 50       20 unless ($loaded) {
1866 8         24 $reader_load_errors{$type} = $error;
1867             }
1868             }
1869              
1870             # probes for an Imager::File::whatever module
1871             sub _writer_autoload {
1872 176     176   270 my $type = shift;
1873              
1874 176 100 66     625 return if $formats_low{$type} || $writers{$type};
1875              
1876 8 50       52 return unless $type =~ /^\w+$/;
1877              
1878 8         27 my $file = "Imager/File/\U$type\E.pm";
1879              
1880 8         9 my $error;
1881 8         75 my $loaded = _load_file($file, \$error);
1882 8 100 66     53 if (!$loaded && $error =~ /^Can't locate /) {
1883 7         52 my $filew = "Imager/File/\U$type\EWriter.pm";
1884 7         20 $loaded = _load_file($filew, \$error);
1885 7 50       40 if ($error =~ /^Can't locate /) {
1886 7         26 $error = "Can't locate $file or $filew";
1887             }
1888             }
1889 8 50       19 unless ($loaded) {
1890 8         23 $writer_load_errors{$type} = $error;
1891             }
1892             }
1893              
1894             sub _fix_gif_positions {
1895 0     0   0 my ($opts, $opt, $msg, @imgs) = @_;
1896              
1897 0         0 my $positions = $opts->{'gif_positions'};
1898 0         0 my $index = 0;
1899 0         0 for my $pos (@$positions) {
1900 0         0 my ($x, $y) = @$pos;
1901 0         0 my $img = $imgs[$index++];
1902 0         0 $img->settag(name=>'gif_left', value=>$x);
1903 0 0       0 $img->settag(name=>'gif_top', value=>$y) if defined $y;
1904             }
1905 0         0 $$msg .= "replaced with the gif_left and gif_top tags";
1906             }
1907              
1908             my %obsolete_opts =
1909             (
1910             gif_each_palette=>'gif_local_map',
1911             interlace => 'gif_interlace',
1912             gif_delays => 'gif_delay',
1913             gif_positions => \&_fix_gif_positions,
1914             gif_loop_count => 'gif_loop',
1915             );
1916              
1917             # options that should be converted to colors
1918             my %color_opts = map { $_ => 1 } qw/i_background/;
1919              
1920             sub _set_opts {
1921 344     344   818 my ($self, $opts, $prefix, @imgs) = @_;
1922              
1923 344         1133 for my $opt (keys %$opts) {
1924 3320         3893 my $tagname = $opt;
1925 3320 50       4680 if ($obsolete_opts{$opt}) {
1926 0         0 my $new = $obsolete_opts{$opt};
1927 0         0 my $msg = "Obsolete option $opt ";
1928 0 0       0 if (ref $new) {
1929 0         0 $new->($opts, $opt, \$msg, @imgs);
1930             }
1931             else {
1932 0         0 $msg .= "replaced with the $new tag ";
1933 0         0 $tagname = $new;
1934             }
1935 0         0 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1936 0 0 0     0 warn $msg if $warn_obsolete && $^W;
1937             }
1938 3320 100       11476 next unless $tagname =~ /^\Q$prefix/;
1939 19         49 my $value = $opts->{$opt};
1940 19 100       51 if ($color_opts{$opt}) {
1941 3         13 $value = _color($value);
1942 3 50       13 unless ($value) {
1943 0         0 $self->_set_error($Imager::ERRSTR);
1944 0         0 return;
1945             }
1946             }
1947 19 100       50 if (ref $value) {
1948 3 50       14 if (UNIVERSAL::isa($value, "Imager::Color")) {
    0          
1949 3         26 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1950 3         9 for my $img (@imgs) {
1951 3         12 $img->settag(name=>$tagname, value=>$tag);
1952             }
1953             }
1954             elsif (ref($value) eq 'ARRAY') {
1955 0         0 for my $i (0..$#$value) {
1956 0         0 my $val = $value->[$i];
1957 0 0       0 if (ref $val) {
1958 0 0       0 if (UNIVERSAL::isa($val, "Imager::Color")) {
1959 0         0 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1960 0 0       0 $i < @imgs and
1961             $imgs[$i]->settag(name=>$tagname, value=>$tag);
1962             }
1963             else {
1964 0         0 $self->_set_error("Unknown reference type " . ref($value) .
1965             " supplied in array for $opt");
1966 0         0 return;
1967             }
1968             }
1969             else {
1970 0 0       0 $i < @imgs
1971             and $imgs[$i]->settag(name=>$tagname, value=>$val);
1972             }
1973             }
1974             }
1975             else {
1976 0         0 $self->_set_error("Unknown reference type " . ref($value) .
1977             " supplied for $opt");
1978 0         0 return;
1979             }
1980             }
1981             else {
1982             # set it as a tag for every image
1983 16         30 for my $img (@imgs) {
1984 16         53 $img->settag(name=>$tagname, value=>$value);
1985             }
1986             }
1987             }
1988              
1989 344         992 return 1;
1990             }
1991              
1992             # Write an image to file
1993             sub write {
1994 175     175 0 19605 my $self = shift;
1995 175         1547 my %input=(jpegquality=>75,
1996             gifquant=>'mc',
1997             lmdither=>6.0,
1998             lmfixed=>[],
1999             idstring=>"",
2000             compress=>1,
2001             wierdpack=>0,
2002             fax_fine=>1, @_);
2003 175         292 my $rc;
2004              
2005 175 100       464 $self->_valid_image("write")
2006             or return;
2007              
2008 174 50       599 $self->_set_opts(\%input, "i_", $self)
2009             or return undef;
2010              
2011 174         359 my $type = $input{'type'};
2012 174 50 66     554 if (!$type and $input{file}) {
2013 99         283 $type = $FORMATGUESS->($input{file});
2014             }
2015 174 50       383 unless ($type) {
2016 0         0 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
2017 0         0 return undef;
2018             }
2019              
2020 174         525 _writer_autoload($type);
2021              
2022 174         267 my ($IO, $fh);
2023 174 50 33     579 if ($writers{$type} && $writers{$type}{single}) {
2024 0 0       0 ($IO, $fh) = $self->_get_writer_io(\%input)
2025             or return undef;
2026              
2027 0 0       0 $writers{$type}{single}->($self, $IO, %input, type => $type)
2028             or return undef;
2029             }
2030             else {
2031 174 100       435 if (!$formats_low{$type}) {
2032 6         22 my $write_types = join ', ', sort Imager->write_types();
2033 6         42 $self->_set_error("format '$type' not supported - formats $write_types available for writing - $writer_load_errors{$type}");
2034 6         39 return undef;
2035             }
2036            
2037 168 50       562 ($IO, $fh) = $self->_get_writer_io(\%input, $type)
2038             or return undef;
2039            
2040 168 100       570 if ( $type eq 'pnm' ) {
    100          
    100          
    50          
2041 121 50       328 $self->_set_opts(\%input, "pnm_", $self)
2042             or return undef;
2043 121 100       31587 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
2044 5         769 $self->{ERRSTR} = $self->_error_as_msg();
2045 5         63 return undef;
2046             }
2047 116 50       724 $self->{DEBUG} && print "writing a pnm file\n";
2048             }
2049             elsif ( $type eq 'raw' ) {
2050 10 50       25 $self->_set_opts(\%input, "raw_", $self)
2051             or return undef;
2052 10 100       1568 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
2053 4         405 $self->{ERRSTR} = $self->_error_as_msg();
2054 4         110 return undef;
2055             }
2056 6 50       217 $self->{DEBUG} && print "writing a raw file\n";
2057             }
2058             elsif ( $type eq 'bmp' ) {
2059 21 50       53 $self->_set_opts(\%input, "bmp_", $self)
2060             or return undef;
2061 21 100       4805 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
2062 12         6707 $self->{ERRSTR} = $self->_error_as_msg;
2063 12         234 return undef;
2064             }
2065 9 50       2189 $self->{DEBUG} && print "writing a bmp file\n";
2066             }
2067             elsif ( $type eq 'tga' ) {
2068 16 50       44 $self->_set_opts(\%input, "tga_", $self)
2069             or return undef;
2070            
2071 16 100       27074 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
2072 4         248 $self->{ERRSTR}=$self->_error_as_msg();
2073 4         416 return undef;
2074             }
2075 12 50       14210 $self->{DEBUG} && print "writing a tga file\n";
2076             }
2077             }
2078              
2079 143 100       365 if (exists $input{'data'}) {
2080 17         3505 my $data = io_slurp($IO);
2081 17 50       84 if (!$data) {
2082 0         0 $self->{ERRSTR}='Could not slurp from buffer';
2083 0         0 return undef;
2084             }
2085 17         30 ${$input{data}} = $data;
  17         60  
2086             }
2087 143         15178 return $self;
2088             }
2089              
2090             sub write_multi {
2091 5     5 0 32 my ($class, $opts, @images) = @_;
2092              
2093 5         12 my $type = $opts->{type};
2094              
2095 5 50 66     21 if (!$type && $opts->{'file'}) {
2096 2         6 $type = $FORMATGUESS->($opts->{'file'});
2097             }
2098 5 50       12 unless ($type) {
2099 0         0 $class->_set_error('type parameter missing and not possible to guess from extension');
2100 0         0 return;
2101             }
2102             # translate to ImgRaw
2103 5         10 my $index = 1;
2104 5         11 for my $img (@images) {
2105 8 100 66     84 unless (ref $img && Scalar::Util::blessed($img) && $img->isa("Imager")) {
      100        
2106 2         9 $class->_set_error("write_multi: image $index is not an Imager image object");
2107 2         8 return;
2108             }
2109 6 100       17 unless ($img->_valid_image("write_multi")) {
2110 1         4 $class->_set_error($img->errstr . " (image $index)");
2111 1         7 return;
2112             }
2113 5         17 ++$index;
2114             }
2115 2 50       7 $class->_set_opts($opts, "i_", @images)
2116             or return;
2117 2         11 my @work = map $_->{IMG}, @images;
2118              
2119 2         5 _writer_autoload($type);
2120              
2121 2         77 my ($IO, $file);
2122 2 50 33     14 if ($writers{$type} && $writers{$type}{multiple}) {
2123 0 0       0 ($IO, $file) = $class->_get_writer_io($opts, $type)
2124             or return undef;
2125              
2126 0 0       0 $writers{$type}{multiple}->($class, $IO, $opts, @images)
2127             or return undef;
2128             }
2129             else {
2130 2 50       8 if (!$formats{$type}) {
2131 2         6 my $write_types = join ', ', sort Imager->write_types();
2132 2         13 $class->_set_error("format '$type' not supported - formats $write_types available for writing");
2133 2         66 return undef;
2134             }
2135            
2136 0 0       0 ($IO, $file) = $class->_get_writer_io($opts, $type)
2137             or return undef;
2138            
2139 0         0 if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
2140             }
2141             else {
2142 0 0       0 if (@images == 1) {
2143 0 0       0 unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
2144 0         0 return 1;
2145             }
2146             }
2147             else {
2148 0         0 $ERRSTR = "Sorry, write_multi doesn't support $type yet";
2149 0         0 return 0;
2150             }
2151             }
2152             }
2153              
2154 0 0       0 if (exists $opts->{'data'}) {
2155 0         0 my $data = io_slurp($IO);
2156 0 0       0 if (!$data) {
2157 0         0 Imager->_set_error('Could not slurp from buffer');
2158 0         0 return undef;
2159             }
2160 0         0 ${$opts->{data}} = $data;
  0         0  
2161             }
2162 0         0 return 1;
2163             }
2164              
2165             # read multiple images from a file
2166             sub read_multi {
2167 5     5 0 39 my ($class, %opts) = @_;
2168              
2169 5 50       25 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
2170             or return;
2171              
2172 5         19 my $type = $opts{'type'};
2173 5 50       14 unless ($type) {
2174 5         15 $type = _test_format($IO);
2175             }
2176              
2177 5 100 100     42 if ($opts{file} && !$type) {
2178             # guess the type
2179 1         13 $type = $FORMATGUESS->($opts{file});
2180             }
2181              
2182 5 100       16 unless ($type) {
2183 2         8 my $msg = "type parameter missing and it couldn't be determined from the file contents";
2184 2 100       7 $opts{file} and $msg .= " or file name";
2185 2         8 Imager->_set_error($msg);
2186 2         203 return;
2187             }
2188              
2189 3         10 _reader_autoload($type);
2190              
2191 3 0 33     19 if ($readers{$type} && $readers{$type}{multiple}) {
2192 0         0 return $readers{$type}{multiple}->($IO, %opts);
2193             }
2194              
2195 3 100       18 unless ($formats{$type}) {
2196 2         9 my $read_types = join ', ', sort Imager->read_types();
2197 2         15 Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
2198 2         40 return;
2199             }
2200              
2201 1         2 my @imgs;
2202 1 50       4 if ($type eq 'pnm') {
2203 1   50     2182 @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
2204             }
2205             else {
2206 0         0 my $img = Imager->new;
2207 0 0       0 if ($img->read(%opts, io => $IO, type => $type)) {
2208 0         0 return ( $img );
2209             }
2210 0         0 Imager->_set_error($img->errstr);
2211 0         0 return;
2212             }
2213              
2214 1 50       8 if (!@imgs) {
2215 0         0 $ERRSTR = _error_as_msg();
2216 0         0 return;
2217             }
2218             return map {
2219 1         4 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
  3         104  
2220             } @imgs;
2221             }
2222              
2223             # Destroy an Imager object
2224              
2225             sub DESTROY {
2226 1275     1275   224482 my $self=shift;
2227             # delete $instances{$self};
2228 1275 100       4210 if (defined($self->{IMG})) {
2229             # the following is now handled by the XS DESTROY method for
2230             # Imager::ImgRaw object
2231             # Re-enabling this will break virtual images
2232             # tested for in t/t020masked.t
2233             # i_img_destroy($self->{IMG});
2234 1117         142967 undef($self->{IMG});
2235             } else {
2236             # print "Destroy Called on an empty image!\n"; # why did I put this here??
2237             }
2238             }
2239              
2240             # Perform an inplace filter of an image
2241             # that is the image will be overwritten with the data
2242              
2243             sub filter {
2244 86     86 0 1208 my $self=shift;
2245 86         315 my %input=@_;
2246 86         136 my %hsh;
2247              
2248 86 100       203 $self->_valid_image("filter")
2249             or return;
2250              
2251 85 50       219 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
  0         0  
  0         0  
2252              
2253 85 50       508 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
  1701         2424  
2254 0         0 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
  0         0  
2255             }
2256              
2257 85 100       313 if ($filters{$input{'type'}}{names}) {
2258 10         16 my $names = $filters{$input{'type'}}{names};
2259 10         24 for my $name (keys %$names) {
2260 40 100 66     89 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2261 12         24 $input{$name} = $names->{$name}{$input{$name}};
2262             }
2263             }
2264             }
2265 85 100       214 if (defined($filters{$input{'type'}}{defaults})) {
2266             %hsh=( image => $self->{IMG},
2267             imager => $self,
2268 84         137 %{$filters{$input{'type'}}{defaults}},
  84         403  
2269             %input );
2270             } else {
2271             %hsh=( image => $self->{IMG},
2272 1         4 imager => $self,
2273             %input );
2274             }
2275              
2276 85         154 my @cs=@{$filters{$input{'type'}}{callseq}};
  85         256  
2277              
2278 85         182 for(@cs) {
2279 290 50       516 if (!defined($hsh{$_})) {
2280 0         0 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
  0         0  
2281             }
2282             }
2283              
2284 85         126 eval {
2285 85         322 local $SIG{__DIE__}; # we don't want this processed by confess, etc
2286 85         185 &{$filters{$input{'type'}}{callsub}}(%hsh);
  85         232  
2287             };
2288 85 100       872 if ($@) {
2289 4         11 chomp($self->{ERRSTR} = $@);
2290 4         22 return;
2291             }
2292              
2293 81         330 my @b=keys %hsh;
2294              
2295 81 50       236 $self->{DEBUG} && print "callseq is: @cs\n";
2296 81 50       174 $self->{DEBUG} && print "matching callseq is: @b\n";
2297              
2298 81         465 return $self;
2299             }
2300              
2301             sub register_filter {
2302 1     1 0 11 my $class = shift;
2303 1         7 my %hsh = ( defaults => {}, @_ );
2304              
2305             defined $hsh{type}
2306 1 50       4 or die "register_filter() with no type\n";
2307             defined $hsh{callsub}
2308 1 50       3 or die "register_filter() with no callsub\n";
2309             defined $hsh{callseq}
2310 1 50       3 or die "register_filter() with no callseq\n";
2311              
2312             exists $filters{$hsh{type}}
2313 1 50       4 and return;
2314              
2315 1         2 $filters{$hsh{type}} = \%hsh;
2316              
2317 1         3 return 1;
2318             }
2319              
2320             sub scale_calculate {
2321 61     61 0 111 my $self = shift;
2322              
2323 61         189 my %opts = ('type'=>'max', @_);
2324              
2325             # none of these should be references
2326 61         167 for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2327 361 100 100     780 if (defined $opts{$name} && ref $opts{$name}) {
2328 1         6 $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2329 1         5 return;
2330             }
2331             }
2332              
2333 60         130 my ($x_scale, $y_scale);
2334 60         111 my $width = $opts{width};
2335 60         95 my $height = $opts{height};
2336 60 100       126 if (ref $self) {
2337 58 50       188 defined $width or $width = $self->getwidth;
2338 58 50       178 defined $height or $height = $self->getheight;
2339             }
2340             else {
2341 2 100 66     12 unless (defined $width && defined $height) {
2342 1         5 $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2343 1         5 return;
2344             }
2345             }
2346              
2347 59 100 100     254 if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
    100          
    100          
2348 8         13 $x_scale = $opts{'xscalefactor'};
2349 8         13 $y_scale = $opts{'yscalefactor'};
2350             }
2351             elsif ($opts{'xscalefactor'}) {
2352 3         7 $x_scale = $opts{'xscalefactor'};
2353 3   33     12 $y_scale = $opts{'scalefactor'} || $x_scale;
2354             }
2355             elsif ($opts{'yscalefactor'}) {
2356 3         5 $y_scale = $opts{'yscalefactor'};
2357 3   33     11 $x_scale = $opts{'scalefactor'} || $y_scale;
2358             }
2359             else {
2360 45   100     144 $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2361             }
2362              
2363             # work out the scaling
2364 59 100 100     325 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
    100 66        
    100 33        
    50 33        
2365             my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2366 19         70 $opts{ypixels} / $height );
2367 19 100 66     71 if ($opts{'type'} eq 'min') {
    100          
    100          
2368 3         9 $x_scale = $y_scale = _min($xpix,$ypix);
2369             }
2370             elsif ($opts{'type'} eq 'max') {
2371 9         27 $x_scale = $y_scale = _max($xpix,$ypix);
2372             }
2373             elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2374 6         10 $x_scale = $xpix;
2375 6         12 $y_scale = $ypix;
2376             }
2377             else {
2378 1         4 $self->_set_error('invalid value for type parameter');
2379 1         5 return;
2380             }
2381             } elsif ($opts{xpixels}) {
2382 6         20 $x_scale = $y_scale = $opts{xpixels} / $width;
2383             }
2384             elsif ($opts{ypixels}) {
2385 3         9 $x_scale = $y_scale = $opts{ypixels}/$height;
2386             }
2387             elsif ($opts{constrain} && ref $opts{constrain}
2388             && $opts{constrain}->can('constrain')) {
2389             # we've been passed an Image::Math::Constrain object or something
2390             # that looks like one
2391 0         0 my $scalefactor;
2392             (undef, undef, $scalefactor)
2393 0         0 = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2394 0 0       0 unless ($scalefactor) {
2395 0         0 $self->_set_error('constrain method failed on constrain parameter');
2396 0         0 return;
2397             }
2398 0         0 $x_scale = $y_scale = $scalefactor;
2399             }
2400              
2401 58         205 my $new_width = int($x_scale * $width + 0.5);
2402 58 100       125 $new_width > 0 or $new_width = 1;
2403 58         109 my $new_height = int($y_scale * $height + 0.5);
2404 58 100       124 $new_height > 0 or $new_height = 1;
2405              
2406 58         270 return ($x_scale, $y_scale, $new_width, $new_height);
2407            
2408             }
2409              
2410             # Scale an image to requested size and return the scaled version
2411              
2412             sub scale {
2413 60     60 0 1870 my $self=shift;
2414 60         277 my %opts = (qtype=>'normal' ,@_);
2415 60         250 my $img = Imager->new();
2416 60         117 my $tmp = Imager->new();
2417              
2418 60 100       121 unless (defined wantarray) {
2419 1         4 my @caller = caller;
2420 1         13 warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2421 1         53 return;
2422             }
2423              
2424 59 100       147 $self->_valid_image("scale")
2425             or return;
2426              
2427 58 100       213 my ($x_scale, $y_scale, $new_width, $new_height) =
2428             $self->scale_calculate(%opts)
2429             or return;
2430              
2431 56 100       243 if ($opts{qtype} eq 'normal') {
    100          
    100          
2432 17         46177 $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2433 17 50       132 if ( !defined($tmp->{IMG}) ) {
2434 0         0 $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
2435 0         0 return undef;
2436             }
2437 17         28225 $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2438 17 50       101 if ( !defined($img->{IMG}) ) {
2439 0         0 $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
2440 0         0 return undef;
2441             }
2442              
2443 17         166 return $img;
2444             }
2445             elsif ($opts{'qtype'} eq 'preview') {
2446 18         9572 $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
2447 18 50       77 if ( !defined($img->{IMG}) ) {
2448 0         0 $self->{ERRSTR}='unable to scale image';
2449 0         0 return undef;
2450             }
2451 18         70 return $img;
2452             }
2453             elsif ($opts{'qtype'} eq 'mixing') {
2454 20         19622 $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2455 20 50       87 unless ($img->{IMG}) {
2456 0         0 $self->_set_error(Imager->_error_as_msg);
2457 0         0 return;
2458             }
2459 20         92 return $img;
2460             }
2461             else {
2462 1         3 $self->_set_error('invalid value for qtype parameter');
2463 1         3 return undef;
2464             }
2465             }
2466              
2467             # Scales only along the X axis
2468              
2469             sub scaleX {
2470 11     11 0 1012 my $self = shift;
2471 11         57 my %opts = ( scalefactor=>0.5, @_ );
2472              
2473 11 100       43 unless (defined wantarray) {
2474 1         4 my @caller = caller;
2475 1         9 warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2476 1         22 return;
2477             }
2478              
2479 10 100       31 $self->_valid_image("scaleX")
2480             or return;
2481              
2482 9         39 my $img = Imager->new();
2483              
2484 9         23 my $scalefactor = $opts{scalefactor};
2485              
2486 9 100       23 if ($opts{pixels}) {
2487 3         10 $scalefactor = $opts{pixels} / $self->getwidth();
2488             }
2489              
2490 9 50       28 unless ($self->{IMG}) {
2491 0         0 $self->{ERRSTR}='empty input image';
2492 0         0 return undef;
2493             }
2494              
2495 9         25799 $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2496              
2497 9 50       76 if ( !defined($img->{IMG}) ) {
2498 0         0 $self->{ERRSTR} = 'unable to scale image';
2499 0         0 return undef;
2500             }
2501              
2502 9         72 return $img;
2503             }
2504              
2505             # Scales only along the Y axis
2506              
2507             sub scaleY {
2508 11     11 0 1068 my $self = shift;
2509 11         56 my %opts = ( scalefactor => 0.5, @_ );
2510              
2511 11 100       41 unless (defined wantarray) {
2512 1         4 my @caller = caller;
2513 1         8 warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2514 1         49 return;
2515             }
2516              
2517 10 100       31 $self->_valid_image("scaleY")
2518             or return;
2519              
2520 9         37 my $img = Imager->new();
2521              
2522 9         20 my $scalefactor = $opts{scalefactor};
2523              
2524 9 100       24 if ($opts{pixels}) {
2525 3         9 $scalefactor = $opts{pixels} / $self->getheight();
2526             }
2527              
2528 9 50       24 unless ($self->{IMG}) {
2529 0         0 $self->{ERRSTR} = 'empty input image';
2530 0         0 return undef;
2531             }
2532 9         41601 $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2533              
2534 9 50       85 if ( !defined($img->{IMG}) ) {
2535 0         0 $self->{ERRSTR} = 'unable to scale image';
2536 0         0 return undef;
2537             }
2538              
2539 9         85 return $img;
2540             }
2541              
2542             # Transform returns a spatial transformation of the input image
2543             # this moves pixels to a new location in the returned image.
2544             # NOTE - should make a utility function to check transforms for
2545             # stack overruns
2546              
2547             our $I2P;
2548              
2549             sub transform {
2550 0     0 0 0 my $self=shift;
2551 0         0 my %opts=@_;
2552 0         0 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2553              
2554             # print Dumper(\%opts);
2555             # xopcopdes
2556              
2557 0 0       0 $self->_valid_image("transform")
2558             or return;
2559              
2560 0 0 0     0 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2561 0 0       0 if (!$I2P) {
2562             {
2563 0         0 local @INC = @INC;
  0         0  
2564 0 0       0 pop @INC if $INC[-1] eq '.';
2565 0         0 eval ("use Affix::Infix2Postfix;");
2566             }
2567              
2568 0 0       0 if ( $@ ) {
2569 0         0 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2570 0         0 return undef;
2571             }
2572 0         0 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2573             {op=>'-',trans=>'Sub'},
2574             {op=>'*',trans=>'Mult'},
2575             {op=>'/',trans=>'Div'},
2576             {op=>'-','type'=>'unary',trans=>'u-'},
2577             {op=>'**'},
2578             {op=>'func','type'=>'unary'}],
2579             'grouping'=>[qw( \( \) )],
2580             'func'=>[qw( sin cos )],
2581             'vars'=>[qw( x y )]
2582             );
2583             }
2584              
2585 0         0 @xt=$I2P->translate($opts{'xexpr'});
2586 0         0 @yt=$I2P->translate($opts{'yexpr'});
2587              
2588 0         0 $numre=$I2P->{'numre'};
2589 0         0 @pt=(0,0);
2590              
2591 0 0       0 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2592 0 0       0 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2593 0         0 @{$opts{'parm'}}=@pt;
  0         0  
2594             }
2595              
2596             # print Dumper(\%opts);
2597              
2598 0 0 0     0 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
  0         0  
2599 0         0 $self->{ERRSTR}='transform: no xopcodes given.';
2600 0         0 return undef;
2601             }
2602              
2603 0         0 @op=@{$opts{'xopcodes'}};
  0         0  
2604 0         0 for $iop (@op) {
2605 0 0 0     0 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2606 0         0 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2607 0         0 return undef;
2608             }
2609 0 0       0 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
  0         0  
2610             }
2611              
2612              
2613             # yopcopdes
2614              
2615 0 0 0     0 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
  0         0  
2616 0         0 $self->{ERRSTR}='transform: no yopcodes given.';
2617 0         0 return undef;
2618             }
2619              
2620 0         0 @op=@{$opts{'yopcodes'}};
  0         0  
2621 0         0 for $iop (@op) {
2622 0 0 0     0 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2623 0         0 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2624 0         0 return undef;
2625             }
2626 0 0       0 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
  0         0  
2627             }
2628              
2629             #parameters
2630              
2631 0 0       0 if ( !exists $opts{'parm'}) {
2632 0         0 $self->{ERRSTR}='transform: no parameter arg given.';
2633 0         0 return undef;
2634             }
2635              
2636             # print Dumper(\@ropx);
2637             # print Dumper(\@ropy);
2638             # print Dumper(\@ropy);
2639              
2640 0         0 my $img = Imager->new();
2641 0         0 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2642 0 0       0 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
  0         0  
  0         0  
2643 0         0 return $img;
2644             }
2645              
2646              
2647             sub transform2 {
2648 30     30 0 1778 my ($opts, @imgs) = @_;
2649            
2650 30         303 require "Imager/Expr.pm";
2651              
2652 30         102 $opts->{variables} = [ qw(x y) ];
2653 30         77 my ($width, $height) = @{$opts}{qw(width height)};
  30         98  
2654 30 100       86 if (@imgs) {
2655 26         49 my $index = 1;
2656 26         61 for my $img (@imgs) {
2657 28 100       88 unless ($img->_valid_image("transform2")) {
2658 1         5 Imager->_set_error($img->errstr . " (input image $index)");
2659 1         10 return;
2660             }
2661 27         55 ++$index;
2662             }
2663              
2664 25   33     151 $width ||= $imgs[0]->getwidth();
2665 25   33     118 $height ||= $imgs[0]->getheight();
2666 25         47 my $img_num = 1;
2667 25         58 for my $img (@imgs) {
2668 26         54 $opts->{constants}{"w$img_num"} = $img->getwidth();
2669 26         47 $opts->{constants}{"h$img_num"} = $img->getheight();
2670 26         84 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2671 26         60 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2672 26         60 ++$img_num;
2673             }
2674             }
2675 29 100       73 if ($width) {
2676 28         68 $opts->{constants}{w} = $width;
2677 28         81 $opts->{constants}{cx} = $width/2;
2678             }
2679             else {
2680 1         3 $Imager::ERRSTR = "No width supplied";
2681 1         3 return;
2682             }
2683 28 50       69 if ($height) {
2684 28         68 $opts->{constants}{h} = $height;
2685 28         91 $opts->{constants}{cy} = $height/2;
2686             }
2687             else {
2688 0         0 $Imager::ERRSTR = "No height supplied";
2689 0         0 return;
2690             }
2691 28         164 my $code = Imager::Expr->new($opts);
2692 28 50       84 if (!$code) {
2693 0         0 $Imager::ERRSTR = Imager::Expr::error();
2694 0         0 return;
2695             }
2696 28   100     105 my $channels = $opts->{channels} || 3;
2697 28 50 33     124 unless ($channels >= 1 && $channels <= 4) {
2698 0         0 return Imager->_set_error("channels must be an integer between 1 and 4");
2699             }
2700              
2701 28         106 my $img = Imager->new();
2702             $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2703             $channels, $code->code(),
2704             $code->nregs(), $code->cregs(),
2705 28         160 [ map { $_->{IMG} } @imgs ]);
  26         25896  
2706 28 100       220 if (!defined $img->{IMG}) {
2707 1         7 $Imager::ERRSTR = Imager->_error_as_msg();
2708 1         6 return;
2709             }
2710              
2711 27         357 return $img;
2712             }
2713              
2714             sub rubthrough {
2715 22     22 0 129 my $self=shift;
2716 22         65 my %opts= @_;
2717              
2718 22 100       50 $self->_valid_image("rubthrough")
2719             or return;
2720              
2721 21 100 66     60 unless ($opts{src} && $opts{src}->_valid_image("rubthrough")) {
2722 1         4 $self->{ERRSTR} = $opts{src}{ERRSTR} . ' (for src)';
2723 1         6 return;
2724             }
2725              
2726             %opts = (src_minx => 0,
2727             src_miny => 0,
2728             src_maxx => $opts{src}->getwidth(),
2729 20         52 src_maxy => $opts{src}->getheight(),
2730             %opts);
2731              
2732 20         39 my $tx = $opts{tx};
2733 20 100       41 defined $tx or $tx = $opts{left};
2734 20 100       34 defined $tx or $tx = 0;
2735              
2736 20         26 my $ty = $opts{ty};
2737 20 100       37 defined $ty or $ty = $opts{top};
2738 20 100       35 defined $ty or $ty = 0;
2739              
2740 20 50       4398 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
2741             $opts{src_minx}, $opts{src_miny},
2742             $opts{src_maxx}, $opts{src_maxy})) {
2743 0         0 $self->_set_error($self->_error_as_msg());
2744 0         0 return undef;
2745             }
2746              
2747 20         141 return $self;
2748             }
2749              
2750             sub compose {
2751 58     58 0 306 my $self = shift;
2752 58         340 my %opts =
2753             (
2754             opacity => 1.0,
2755             mask_left => 0,
2756             mask_top => 0,
2757             @_
2758             );
2759              
2760 58 100       143 $self->_valid_image("compose")
2761             or return;
2762              
2763 57 50       161 unless ($opts{src}) {
2764 0         0 $self->_set_error("compose: src parameter missing");
2765 0         0 return;
2766             }
2767            
2768 57 100       138 unless ($opts{src}->_valid_image("compose")) {
2769 1         4 $self->_set_error($opts{src}->errstr . " (for src)");
2770 1         4 return;
2771             }
2772 56         95 my $src = $opts{src};
2773              
2774 56         75 my $left = $opts{left};
2775 56 50       243 defined $left or $left = $opts{tx};
2776 56 100       122 defined $left or $left = 0;
2777              
2778 56         86 my $top = $opts{top};
2779 56 50       110 defined $top or $top = $opts{ty};
2780 56 100       96 defined $top or $top = 0;
2781              
2782 56         124 my $src_left = $opts{src_left};
2783 56 100       114 defined $src_left or $src_left = $opts{src_minx};
2784 56 100       110 defined $src_left or $src_left = 0;
2785              
2786 56         73 my $src_top = $opts{src_top};
2787 56 100       134 defined $src_top or $src_top = $opts{src_miny};
2788 56 100       88 defined $src_top or $src_top = 0;
2789              
2790 56         68 my $width = $opts{width};
2791 56 50 66     186 if (!defined $width && defined $opts{src_maxx}) {
2792 0         0 $width = $opts{src_maxx} - $src_left;
2793             }
2794 56 100       174 defined $width or $width = $src->getwidth() - $src_left;
2795              
2796 56         76 my $height = $opts{height};
2797 56 50 66     191 if (!defined $height && defined $opts{src_maxy}) {
2798 0         0 $height = $opts{src_maxy} - $src_top;
2799             }
2800 56 100       151 defined $height or $height = $src->getheight() - $src_top;
2801              
2802 56         241 my $combine = $self->_combine($opts{combine}, 'normal');
2803              
2804 56 100       154 if ($opts{mask}) {
2805 31 100       91 unless ($opts{mask}->_valid_image("compose")) {
2806 1         5 $self->_set_error($opts{mask}->errstr . " (for mask)");
2807 1         5 return;
2808             }
2809              
2810 30         65 my $mask_left = $opts{mask_left};
2811 30 50       57 defined $mask_left or $mask_left = $opts{mask_minx};
2812 30 50       61 defined $mask_left or $mask_left = 0;
2813            
2814 30         45 my $mask_top = $opts{mask_top};
2815 30 50       69 defined $mask_top or $mask_top = $opts{mask_miny};
2816 30 50       51 defined $mask_top or $mask_top = 0;
2817              
2818 30 100       6729 unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
2819             $left, $top, $src_left, $src_top,
2820             $mask_left, $mask_top, $width, $height,
2821             $combine, $opts{opacity})) {
2822 10         45 $self->_set_error(Imager->_error_as_msg);
2823 10         73 return;
2824             }
2825             }
2826             else {
2827 25 100       3923 unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2828             $width, $height, $combine, $opts{opacity})) {
2829 10         42 $self->_set_error(Imager->_error_as_msg);
2830 10         69 return;
2831             }
2832             }
2833              
2834 35         331 return $self;
2835             }
2836              
2837             sub flip {
2838 144     144 0 757 my $self = shift;
2839 144         267 my %opts = @_;
2840              
2841 144 100       230 $self->_valid_image("flip")
2842             or return;
2843              
2844 143         365 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2845 143         156 my $dir;
2846 143 50 33     387 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2847 143         184 $dir = $xlate{$opts{'dir'}};
2848 143 50       12316 return $self if i_flipxy($self->{IMG}, $dir);
2849 0         0 return ();
2850             }
2851              
2852             sub rotate {
2853 41     41 0 1535 my $self = shift;
2854 41         106 my %opts = @_;
2855              
2856 41 100       88 unless (defined wantarray) {
2857 1         3 my @caller = caller;
2858 1         11 warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2859 1         24 return;
2860             }
2861              
2862 40 100       74 $self->_valid_image("rotate")
2863             or return;
2864              
2865 39 100 33     112 if (defined $opts{right}) {
    50          
2866 28         31 my $degrees = $opts{right};
2867 28 50       57 if ($degrees < 0) {
2868 0         0 $degrees += 360 * int(((-$degrees)+360)/360);
2869             }
2870 28         39 $degrees = $degrees % 360;
2871 28 100 100     91 if ($degrees == 0) {
    50 66        
2872 2         5 return $self->copy();
2873             }
2874             elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2875 26         48 my $result = Imager->new();
2876 26 50       12028 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2877 26         120 return $result;
2878             }
2879             else {
2880 0         0 $self->{ERRSTR} = $self->_error_as_msg();
2881 0         0 return undef;
2882             }
2883             }
2884             else {
2885 0         0 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2886 0         0 return undef;
2887             }
2888             }
2889             elsif (defined $opts{radians} || defined $opts{degrees}) {
2890 11   33     97 my $amount = $opts{radians} || $opts{degrees} * 3.14159265358979 / 180;
2891              
2892 11         21 my $back = $opts{back};
2893 11         31 my $result = Imager->new;
2894 11 100       25 if ($back) {
2895 6         14 $back = _color($back);
2896 6 100       15 unless ($back) {
2897 1         5 $self->_set_error(Imager->errstr);
2898 1         3 return undef;
2899             }
2900              
2901 5         13387 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2902             }
2903             else {
2904 5         7472 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2905             }
2906 10 50       46 if ($result->{IMG}) {
2907 10         219 return $result;
2908             }
2909             else {
2910 0         0 $self->{ERRSTR} = $self->_error_as_msg();
2911 0         0 return undef;
2912             }
2913             }
2914             else {
2915 0         0 $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2916 0         0 return undef;
2917             }
2918             }
2919              
2920             sub matrix_transform {
2921 5     5 0 778 my $self = shift;
2922 5         12 my %opts = @_;
2923              
2924 5 100       11 $self->_valid_image("matrix_transform")
2925             or return;
2926              
2927 4 100       9 unless (defined wantarray) {
2928 1         4 my @caller = caller;
2929 1         9 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2930 1         24 return;
2931             }
2932              
2933 3 50       7 if ($opts{matrix}) {
2934 3   33     10 my $xsize = $opts{xsize} || $self->getwidth;
2935 3   33     12 my $ysize = $opts{ysize} || $self->getheight;
2936              
2937 3         9 my $result = Imager->new;
2938 3 100       7 if ($opts{back}) {
2939             $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2940             $opts{matrix}, $opts{back})
2941 1 50       1159 or return undef;
2942             }
2943             else {
2944             $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2945             $opts{matrix})
2946 2 50       1367 or return undef;
2947             }
2948              
2949 3         16 return $result;
2950             }
2951             else {
2952 0         0 $self->{ERRSTR} = "matrix parameter required";
2953 0         0 return undef;
2954             }
2955             }
2956              
2957             # blame Leolo :)
2958             *yatf = \&matrix_transform;
2959              
2960             # These two are supported for legacy code only
2961              
2962             sub i_color_new {
2963 254     254 0 27385 return Imager::Color->new(@_);
2964             }
2965              
2966             sub i_color_set {
2967 0     0 0 0 return Imager::Color::set(@_);
2968             }
2969              
2970             # Draws a box between the specified corner points.
2971             sub box {
2972 981     981 0 15263 my $self=shift;
2973 981         1320 my $raw = $self->{IMG};
2974              
2975 981 100       1989 $self->_valid_image("box")
2976             or return;
2977              
2978 980         2649 my %opts = @_;
2979              
2980 980         1328 my ($xmin, $ymin, $xmax, $ymax);
2981 980 100       1590 if (exists $opts{'box'}) {
2982 565         1067 $xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2983 565         892 $xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2984 565         946 $ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2985 565         806 $ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2986             }
2987             else {
2988 415 100       831 defined($xmin = $opts{xmin}) or $xmin = 0;
2989 415 100       981 defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
2990 415 100       781 defined($ymin = $opts{ymin}) or $ymin = 0;
2991 415 100       909 defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
2992             }
2993              
2994 980 100       1600 if ($opts{filled}) {
    100          
2995 863         1069 my $color = $opts{'color'};
2996              
2997 863 100       1265 if (defined $color) {
2998 861 100       2475 unless (_is_color_object($color)) {
2999 145         245 $color = _color($color);
3000 145 50       351 unless ($color) {
3001 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3002 0         0 return;
3003             }
3004             }
3005             }
3006             else {
3007 2         15 $color = i_color_new(255,255,255,255);
3008             }
3009              
3010 863 100       2059 if ($color->isa("Imager::Color")) {
3011 826         52627 i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
3012             }
3013             else {
3014 37         3514 i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
3015             }
3016             }
3017             elsif ($opts{fill}) {
3018 113 100       270 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3019             # assume it's a hash ref
3020 6         1405 require 'Imager/Fill.pm';
3021 6 50       16 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
  6         39  
3022 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3023 0         0 return undef;
3024             }
3025             }
3026 113         24913 i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
3027             }
3028             else {
3029 4         8 my $color = $opts{'color'};
3030 4 100       9 if (defined $color) {
3031 3 100       32 unless (_is_color_object($color)) {
3032 2         6 $color = _color($color);
3033 2 50       9 unless ($color) {
3034 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3035 0         0 return;
3036             }
3037             }
3038             }
3039             else {
3040 1         3 $color = i_color_new(255, 255, 255, 255);
3041             }
3042 4 50       16 unless ($color) {
3043 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3044 0         0 return;
3045             }
3046 4         320 i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
3047             }
3048              
3049 980         3246 return $self;
3050             }
3051              
3052             sub arc {
3053 257     257 0 1094 my $self=shift;
3054              
3055 257 100       515 $self->_valid_image("arc")
3056             or return;
3057              
3058 256         555 my $dflcl= [ 255, 255, 255, 255];
3059 256         321 my $good = 1;
3060 256         570 my %opts=
3061             (
3062             color=>$dflcl,
3063             'r'=>_min($self->getwidth(),$self->getheight())/3,
3064             'x'=>$self->getwidth()/2,
3065             'y'=>$self->getheight()/2,
3066             'd1'=>0, 'd2'=>361,
3067             filled => 1,
3068             @_,
3069             );
3070 256 100       587 if ($opts{aa}) {
3071 133 100       283 if ($opts{fill}) {
    100          
3072 2 50       7 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3073             # assume it's a hash ref
3074 2         10 require 'Imager/Fill.pm';
3075 2 50       3 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
  2         8  
3076 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3077 0         0 return;
3078             }
3079             }
3080 2 100 66     11 if ($opts{d1} == 0 && $opts{d2} == 361) {
3081             i_circle_aa_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
3082 1         436 $opts{fill}{fill});
3083             }
3084             else {
3085             i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
3086 1         779 $opts{'d2'}, $opts{fill}{fill});
3087             }
3088             }
3089             elsif ($opts{filled}) {
3090 33         81 my $color = _color($opts{'color'});
3091 33 50       89 unless ($color) {
3092 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3093 0         0 return;
3094             }
3095 33 100 100     117 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
      66        
3096 8         3102 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
3097             $color);
3098             }
3099             else {
3100             i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
3101 25         103245 $opts{'d1'}, $opts{'d2'}, $color);
3102             }
3103             }
3104             else {
3105 98         162 my $color = _color($opts{'color'});
3106 98 100       274 if ($opts{d2} - $opts{d1} >= 360) {
3107 25         4180 $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
3108             }
3109             else {
3110 73         8869 $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
3111             }
3112             }
3113             }
3114             else {
3115 123 100       235 if ($opts{fill}) {
3116 10 50       42 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3117             # assume it's a hash ref
3118 10         605 require 'Imager/Fill.pm';
3119 10 100       17 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
  10         54  
3120 1         4 $self->{ERRSTR} = $Imager::ERRSTR;
3121 1         7 return;
3122             }
3123             }
3124             i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
3125 9         49060 $opts{'d2'}, $opts{fill}{fill});
3126             }
3127             else {
3128 113         244 my $color = _color($opts{'color'});
3129 113 50       256 unless ($color) {
3130 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3131 0         0 return;
3132             }
3133 113 100       233 if ($opts{filled}) {
3134             i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
3135 51         271343 $opts{'d1'}, $opts{'d2'}, $color);
3136             }
3137             else {
3138 62 100 100     151 if ($opts{d1} == 0 && $opts{d2} == 361) {
3139 13         1265 $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
3140             }
3141             else {
3142 49         4978 $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
3143             }
3144             }
3145             }
3146             }
3147 254 50       2664 unless ($good) {
3148 0         0 $self->_set_error($self->_error_as_msg);
3149 0         0 return;
3150             }
3151              
3152 254         2131 return $self;
3153             }
3154              
3155             # Draws a line from one point to the other
3156             # the endpoint is set if the endp parameter is set which it is by default.
3157             # to turn of the endpoint being set use endp=>0 when calling line.
3158              
3159             sub line {
3160 212     212 0 2298 my $self=shift;
3161 212         340 my $dflcl=i_color_new(0,0,0,0);
3162 212         1082 my %opts=(color=>$dflcl,
3163             endp => 1,
3164             @_);
3165              
3166 212 100       464 $self->_valid_image("line")
3167             or return;
3168              
3169 211 50 33     539 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
  0         0  
  0         0  
3170 211 50 33     504 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
  0         0  
  0         0  
3171              
3172 211         294 my $color = _color($opts{'color'});
3173 211 50       335 unless ($color) {
3174 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3175 0         0 return;
3176             }
3177              
3178 211 100       377 $opts{antialias} = $opts{aa} if defined $opts{aa};
3179 211 100       269 if ($opts{antialias}) {
3180             i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
3181 146         4266 $color, $opts{endp});
3182             } else {
3183             i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
3184 65         484 $color, $opts{endp});
3185             }
3186 211         12375 return $self;
3187             }
3188              
3189             # Draws a line between an ordered set of points - It more or less just transforms this
3190             # into a list of lines.
3191              
3192             sub polyline {
3193 6     6 0 720 my $self=shift;
3194 6         13 my ($pt,$ls,@points);
3195 6         11 my $dflcl=i_color_new(0,0,0,0);
3196 6         30 my %opts=(color=>$dflcl,@_);
3197              
3198 6 100       18 $self->_valid_image("polyline")
3199             or return;
3200              
3201 5 100       18 if (exists($opts{points})) { @points=@{$opts{points}}; }
  1         2  
  1         3  
3202 5 50 66     35 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
      33        
3203 4         9 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
  269         364  
  4         13  
3204             }
3205              
3206             # print Dumper(\@points);
3207              
3208 5         18 my $color = _color($opts{'color'});
3209 5 50       12 unless ($color) {
3210 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3211 0         0 return;
3212             }
3213 5 100       14 $opts{antialias} = $opts{aa} if defined $opts{aa};
3214 5 100       21 if ($opts{antialias}) {
3215 2         5 for $pt(@points) {
3216 6 100       10 if (defined($ls)) {
3217 4         31 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3218             }
3219 6         7 $ls=$pt;
3220             }
3221             } else {
3222 3         8 for $pt(@points) {
3223 266 100       348 if (defined($ls)) {
3224 263         694 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3225             }
3226 266         279 $ls=$pt;
3227             }
3228             }
3229 5         410 return $self;
3230             }
3231              
3232             sub polygon {
3233 11     11 0 7897 my $self = shift;
3234 11         18 my ($pt,$ls,@points);
3235 11         26 my $dflcl = i_color_new(0,0,0,0);
3236 11         57 my %opts = (color=>$dflcl, @_);
3237              
3238 11 100       26 $self->_valid_image("polygon")
3239             or return;
3240              
3241 10 100       26 if (exists($opts{points})) {
3242 8         10 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
  1044         1156  
  8         18  
3243 8         32 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
  1044         1193  
  8         14  
3244             }
3245              
3246 10 50 33     55 if (!exists $opts{'x'} or !exists $opts{'y'}) {
3247 0         0 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
  0         0  
3248             }
3249              
3250 10         52 my $mode = _first($opts{mode}, 0);
3251              
3252 10 100       26 if ($opts{'fill'}) {
3253 4 100       17 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
3254             # assume it's a hash ref
3255 3         540 require 'Imager/Fill.pm';
3256 3 50       7 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
  3         20  
3257 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3258 0         0 return undef;
3259             }
3260             }
3261 4 100       6674 unless (i_poly_aa_cfill_m($self->{IMG}, $opts{'x'}, $opts{'y'},
3262             $mode, $opts{'fill'}{'fill'})) {
3263 1         5 return $self->_set_error($self->_error_as_msg);
3264             }
3265             }
3266             else {
3267 6         12 my $color = _color($opts{'color'});
3268 6 50       12 unless ($color) {
3269 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3270 0         0 return;
3271             }
3272 6 100       8515 unless (i_poly_aa_m($self->{IMG}, $opts{'x'}, $opts{'y'}, $mode, $color)) {
3273 1         8 return $self->_set_error($self->_error_as_msg);
3274             }
3275             }
3276              
3277 8         550 return $self;
3278             }
3279              
3280             sub polypolygon {
3281 6     6 0 88 my ($self, %opts) = @_;
3282              
3283 6 50       19 $self->_valid_image("polypolygon")
3284             or return;
3285              
3286 6         18 my $points = $opts{points};
3287 6 50       16 $points
3288             or return $self->_set_error("polypolygon: missing required points");
3289              
3290 6         18 my $mode = _first($opts{mode}, "evenodd");
3291              
3292 6 50       21 if ($opts{filled}) {
    0          
3293 6 50       24 my $color = _color(_first($opts{color}, [ 0, 0, 0, 0 ]))
3294             or return $self->_set_error($Imager::ERRSTR);
3295              
3296 6 50       5852 i_poly_poly_aa($self->{IMG}, $points, $mode, $color)
3297             or return $self->_set_error($self->_error_as_msg);
3298             }
3299             elsif ($opts{fill}) {
3300 0         0 my $fill = $opts{fill};
3301 0 0       0 $self->_valid_fill($fill, "polypolygon")
3302             or return;
3303              
3304             i_poly_poly_aa_cfill($self->{IMG}, $points, $mode, $fill->{fill})
3305 0 0       0 or return $self->_set_error($self->_error_as_msg);
3306             }
3307             else {
3308 0 0       0 my $color = _color(_first($opts{color}, [ 0, 0, 0, 255 ]))
3309             or return $self->_set_error($Imager::ERRSTR);
3310              
3311 0         0 my $rimg = $self->{IMG};
3312              
3313 0 0       0 if (_first($opts{aa}, 1)) {
3314 0         0 for my $poly (@$points) {
3315 0         0 my $xp = $poly->[0];
3316 0         0 my $yp = $poly->[1];
3317 0         0 for my $i (0 .. $#$xp - 1) {
3318 0         0 i_line_aa($rimg, $xp->[$i], $yp->[$i], $xp->[$i+1], $yp->[$i+1],
3319             $color, 0);
3320             }
3321 0         0 i_line_aa($rimg, $xp->[$#$xp], $yp->[$#$yp], $xp->[0], $yp->[0],
3322             $color, 0);
3323             }
3324             }
3325             else {
3326 0         0 for my $poly (@$points) {
3327 0         0 my $xp = $poly->[0];
3328 0         0 my $yp = $poly->[1];
3329 0         0 for my $i (0 .. $#$xp - 1) {
3330 0         0 i_line($rimg, $xp->[$i], $yp->[$i], $xp->[$i+1], $yp->[$i+1],
3331             $color, 0);
3332             }
3333 0         0 i_line($rimg, $xp->[$#$xp], $yp->[$#$yp], $xp->[0], $yp->[0],
3334             $color, 0);
3335             }
3336             }
3337             }
3338              
3339 6         59 return $self;
3340             }
3341              
3342             # this the multipoint bezier curve
3343             # this is here more for testing that actual usage since
3344             # this is not a good algorithm. Usually the curve would be
3345             # broken into smaller segments and each done individually.
3346              
3347             sub polybezier {
3348 0     0 0 0 my $self=shift;
3349 0         0 my ($pt,$ls,@points);
3350 0         0 my $dflcl=i_color_new(0,0,0,0);
3351 0         0 my %opts=(color=>$dflcl,@_);
3352              
3353 0 0       0 $self->_valid_image("polybezier")
3354             or return;
3355              
3356 0 0       0 if (exists $opts{points}) {
3357 0         0 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
  0         0  
  0         0  
3358 0         0 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
  0         0  
  0         0  
3359             }
3360              
3361 0 0 0     0 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
  0         0  
  0         0  
  0         0  
3362 0         0 $self->{ERRSTR}='Missing or invalid points.';
3363 0         0 return;
3364             }
3365              
3366 0         0 my $color = _color($opts{'color'});
3367 0 0       0 unless ($color) {
3368 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3369 0         0 return;
3370             }
3371 0         0 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
3372 0         0 return $self;
3373             }
3374              
3375             sub flood_fill {
3376 90     90 0 531 my $self = shift;
3377 90         233 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
3378 90         338 my $rc;
3379              
3380 90 100       156 $self->_valid_image("flood_fill")
3381             or return;
3382              
3383 89 50 33     257 unless (exists $opts{'x'} && exists $opts{'y'}) {
3384 0         0 $self->{ERRSTR} = "missing seed x and y parameters";
3385 0         0 return undef;
3386             }
3387              
3388 89 100       139 if ($opts{border}) {
3389 2         7 my $border = _color($opts{border});
3390 2 50       7 unless ($border) {
3391 0         0 $self->_set_error($Imager::ERRSTR);
3392 0         0 return;
3393             }
3394 2 100       7 if ($opts{fill}) {
3395 1 50       6 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3396             # assume it's a hash ref
3397 1         9 require Imager::Fill;
3398 1 50       3 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
  1         10  
3399 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3400 0         0 return;
3401             }
3402             }
3403             $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3404 1         10335 $opts{fill}{fill}, $border);
3405             }
3406             else {
3407 1         4 my $color = _color($opts{'color'});
3408 1 50       4 unless ($color) {
3409 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3410 0         0 return;
3411             }
3412 1         10113 $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3413             $color, $border);
3414             }
3415 2 50       14 if ($rc) {
3416 2         189 return $self;
3417             }
3418             else {
3419 0         0 $self->{ERRSTR} = $self->_error_as_msg();
3420 0         0 return;
3421             }
3422             }
3423             else {
3424 87 100       114 if ($opts{fill}) {
3425 1 50       6 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3426             # assume it's a hash ref
3427 1         11 require 'Imager/Fill.pm';
3428 1 50       2 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
  1         11  
3429 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3430 0         0 return;
3431             }
3432             }
3433 1         10427 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3434             }
3435             else {
3436 86         142 my $color = _color($opts{'color'});
3437 86 50       149 unless ($color) {
3438 0         0 $self->{ERRSTR} = $Imager::ERRSTR;
3439 0         0 return;
3440             }
3441 86         12884 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3442             }
3443 87 50       207 if ($rc) {
3444 87         481 return $self;
3445             }
3446             else {
3447 0         0 $self->{ERRSTR} = $self->_error_as_msg();
3448 0         0 return;
3449             }
3450             }
3451             }
3452              
3453             sub setpixel {
3454 128     128 0 1071 my ($self, %opts) = @_;
3455              
3456 128 100       283 $self->_valid_image("setpixel")
3457             or return;
3458              
3459 127         249 my $color = $opts{color};
3460 127 100       250 unless (defined $color) {
3461 1         7 $color = $self->{fg};
3462 1 50       6 defined $color or $color = NC(255, 255, 255);
3463             }
3464              
3465 127 100 100     518 unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3466 84 100       225 unless ($color = _color($color, 'setpixel')) {
3467 1         4 $self->_set_error("setpixel: " . Imager->errstr);
3468 1         5 return;
3469             }
3470             }
3471              
3472 126 100 100     471 unless (exists $opts{'x'} && exists $opts{'y'}) {
3473 2         5 $self->_set_error('setpixel: missing x or y parameter');
3474 2         9 return;
3475             }
3476              
3477 124         203 my $x = $opts{'x'};
3478 124         218 my $y = $opts{'y'};
3479 124 100 100     422 if (ref $x || ref $y) {
3480 9 100       19 $x = ref $x ? $x : [ $x ];
3481 9 100       16 $y = ref $y ? $y : [ $y ];
3482 9 100       19 unless (@$x) {
3483 1         4 $self->_set_error("setpixel: x is a reference to an empty array");
3484 1         5 return;
3485             }
3486 8 100       13 unless (@$y) {
3487 1         3 $self->_set_error("setpixel: y is a reference to an empty array");
3488 1         5 return;
3489             }
3490              
3491             # make both the same length, replicating the last element
3492 7 100       23 if (@$x < @$y) {
    100          
3493 1         5 $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3494             }
3495             elsif (@$y < @$x) {
3496 1         4 $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3497             }
3498              
3499 7         11 my $set = 0;
3500 7 100       22 if ($color->isa('Imager::Color')) {
3501 5         14 for my $i (0..$#$x) {
3502 17 100       52 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3503             or ++$set;
3504             }
3505             }
3506             else {
3507 2         9 for my $i (0..$#$x) {
3508 8 100       40 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3509             or ++$set;
3510             }
3511             }
3512              
3513 7         113 return $set;
3514             }
3515             else {
3516 115 100       398 if ($color->isa('Imager::Color')) {
3517 84 100       495 i_ppix($self->{IMG}, $x, $y, $color)
3518             and return "0 but true";
3519             }
3520             else {
3521 31 100       246 i_ppixf($self->{IMG}, $x, $y, $color)
3522             and return "0 but true";
3523             }
3524              
3525 79         3212 return 1;
3526             }
3527             }
3528              
3529             sub getpixel {
3530 239     239 0 5165 my $self = shift;
3531              
3532 239         831 my %opts = ( "type"=>'8bit', @_);
3533              
3534 239 100       511 $self->_valid_image("getpixel")
3535             or return;
3536              
3537 238 100 100     858 unless (exists $opts{'x'} && exists $opts{'y'}) {
3538 2         6 $self->_set_error('getpixel: missing x or y parameter');
3539 2         8 return;
3540             }
3541              
3542 236         441 my $x = $opts{'x'};
3543 236         317 my $y = $opts{'y'};
3544 236         333 my $type = $opts{'type'};
3545 236 100 100     759 if (ref $x || ref $y) {
3546 19 100       35 $x = ref $x ? $x : [ $x ];
3547 19 100       34 $y = ref $y ? $y : [ $y ];
3548 19 100       44 unless (@$x) {
3549 1         3 $self->_set_error("getpixel: x is a reference to an empty array");
3550 1         5 return;
3551             }
3552 18 100       35 unless (@$y) {
3553 1         4 $self->_set_error("getpixel: y is a reference to an empty array");
3554 1         4 return;
3555             }
3556              
3557             # make both the same length, replicating the last element
3558 17 100       51 if (@$x < @$y) {
    100          
3559 1         5 $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3560             }
3561             elsif (@$y < @$x) {
3562 3         8 $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3563             }
3564              
3565 17         20 my @result;
3566 17 100 66     48 if ($type eq '8bit') {
    100          
3567 13         36 for my $i (0..$#$x) {
3568 40         1533 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3569             }
3570             }
3571             elsif ($type eq 'float' || $type eq 'double') {
3572 3         10 for my $i (0..$#$x) {
3573 10         371 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3574             }
3575             }
3576             else {
3577 1         2 $self->_set_error("getpixel: type must be '8bit' or 'float'");
3578 1         4 return;
3579             }
3580 16 50       263 return wantarray ? @result : \@result;
3581             }
3582             else {
3583 217 100 100     483 if ($type eq '8bit') {
    100          
3584 195         8564 return i_get_pixel($self->{IMG}, $x, $y);
3585             }
3586             elsif ($type eq 'float' || $type eq 'double') {
3587 21         994 return i_gpixf($self->{IMG}, $x, $y);
3588             }
3589             else {
3590 1         4 $self->_set_error("getpixel: type must be '8bit' or 'float'");
3591 1         4 return;
3592             }
3593             }
3594             }
3595              
3596             sub getscanline {
3597 39     39 0 3168 my $self = shift;
3598 39         130 my %opts = ( type => '8bit', x=>0, @_);
3599              
3600 39 100       78 $self->_valid_image("getscanline")
3601             or return;
3602              
3603 38 100       97 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3604              
3605 38 100       71 unless (defined $opts{'y'}) {
3606 1         5 $self->_set_error("missing y parameter");
3607 1         5 return;
3608             }
3609              
3610 37 100       103 if ($opts{type} eq '8bit') {
    100          
    100          
3611             return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3612 16         3712 $opts{'y'});
3613             }
3614             elsif ($opts{type} eq 'float') {
3615             return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3616 12         1759 $opts{'y'});
3617             }
3618             elsif ($opts{type} eq 'index') {
3619 8 50       25 unless (i_img_type($self->{IMG})) {
3620 0         0 $self->_set_error("type => index only valid on paletted images");
3621 0         0 return;
3622             }
3623             return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3624 8         557 $opts{'y'});
3625             }
3626             else {
3627 1         5 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3628 1         5 return;
3629             }
3630             }
3631              
3632             sub setscanline {
3633 215     215 0 8261 my $self = shift;
3634 215         586 my %opts = ( x=>0, @_);
3635              
3636 215 100       399 $self->_valid_image("setscanline")
3637             or return;
3638              
3639 214 50       460 unless (defined $opts{'y'}) {
3640 0         0 $self->_set_error("missing y parameter");
3641 0         0 return;
3642             }
3643              
3644 214 100       348 if (!$opts{type}) {
3645 200 100 66     403 if (ref $opts{pixels} && @{$opts{pixels}}) {
  49         134  
3646             # try to guess the type
3647 49 100       219 if ($opts{pixels}[0]->isa('Imager::Color')) {
    50          
3648 32         89 $opts{type} = '8bit';
3649             }
3650             elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3651 17         31 $opts{type} = 'float';
3652             }
3653             else {
3654 0         0 $self->_set_error("missing type parameter and could not guess from pixels");
3655 0         0 return;
3656             }
3657             }
3658             else {
3659             # default
3660 151         202 $opts{type} = '8bit';
3661             }
3662             }
3663              
3664 214 100       436 if ($opts{type} eq '8bit') {
    100          
    50          
3665 183 100       263 if (ref $opts{pixels}) {
3666 32         56 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
  32         2297  
3667             }
3668             else {
3669 151         895 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3670             }
3671             }
3672             elsif ($opts{type} eq 'float') {
3673 18 100       39 if (ref $opts{pixels}) {
3674 17         28 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
  17         1164  
3675             }
3676             else {
3677 1         9 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3678             }
3679             }
3680             elsif ($opts{type} eq 'index') {
3681 13 100       28 if (ref $opts{pixels}) {
3682 9         12 return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
  9         85  
3683             }
3684             else {
3685 4         34 return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3686             }
3687             }
3688             else {
3689 0         0 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3690 0         0 return;
3691             }
3692             }
3693              
3694             sub getsamples {
3695 313     313 0 7017 my $self = shift;
3696 313         829 my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3697              
3698 313 100       518 $self->_valid_image("getsamples")
3699             or return;
3700              
3701 312 100       704 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3702              
3703 312 50       500 unless (defined $opts{'y'}) {
3704 0         0 $self->_set_error("missing y parameter");
3705 0         0 return;
3706             }
3707            
3708 312 100       458 if ($opts{target}) {
3709 3         6 my $target = $opts{target};
3710 3         5 my $offset = $opts{offset};
3711 3 100       20 if ($opts{type} eq '8bit') {
    100          
    50          
3712             my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3713             $opts{y}, $opts{channels})
3714 1 50       70 or return;
3715 1         6 @{$target}[$offset .. $offset + @samples - 1] = @samples;
  1         4  
3716 1         8 return scalar(@samples);
3717             }
3718             elsif ($opts{type} eq 'float') {
3719             my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3720 1         66 $opts{y}, $opts{channels});
3721 1         6 @{$target}[$offset .. $offset + @samples - 1] = @samples;
  1         5  
3722 1         7 return scalar(@samples);
3723             }
3724             elsif ($opts{type} =~ /^(\d+)bit$/) {
3725 1         4 my $bits = $1;
3726              
3727 1         1 my @data;
3728             my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3729             $opts{y}, $bits, $target,
3730 1         73 $offset, $opts{channels});
3731 1 50       7 unless (defined $count) {
3732 0         0 $self->_set_error(Imager->_error_as_msg);
3733 0         0 return;
3734             }
3735              
3736 1         6 return $count;
3737             }
3738             else {
3739 0         0 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3740 0         0 return;
3741             }
3742             }
3743             else {
3744 309 100       552 if ($opts{type} eq '8bit') {
    50          
    0          
3745             return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3746 297         18599 $opts{y}, $opts{channels});
3747             }
3748             elsif ($opts{type} eq 'float') {
3749             return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3750 12         926 $opts{y}, $opts{channels});
3751             }
3752             elsif ($opts{type} =~ /^(\d+)bit$/) {
3753 0         0 my $bits = $1;
3754              
3755 0         0 my @data;
3756             i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3757             $opts{y}, $bits, \@data, 0, $opts{channels})
3758 0 0       0 or return;
3759 0         0 return @data;
3760             }
3761             else {
3762 0         0 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3763 0         0 return;
3764             }
3765             }
3766             }
3767              
3768             sub setsamples {
3769 15     15 0 92 my $self = shift;
3770              
3771 15 100       27 $self->_valid_image("setsamples")
3772             or return;
3773              
3774 14         37 my %opts = ( x => 0, offset => 0 );
3775 14         21 my $data_index;
3776             # avoid duplicating the data parameter, it may be a large scalar
3777 14         16 my $i = 0;
3778 14         29 while ($i < @_ -1) {
3779 48 100       107 if ($_[$i] eq 'data') {
3780 13         18 $data_index = $i+1;
3781             }
3782             else {
3783 35         56 $opts{$_[$i]} = $_[$i+1];
3784             }
3785              
3786 48         76 $i += 2;
3787             }
3788              
3789 14 100       20 unless(defined $data_index) {
3790 1         3 $self->_set_error('setsamples: data parameter missing');
3791 1         4 return;
3792             }
3793 13 100       26 unless (defined $_[$data_index]) {
3794 1         3 $self->_set_error('setsamples: data parameter not defined');
3795 1         4 return;
3796             }
3797              
3798 12         15 my $type = $opts{type};
3799 12 100       19 defined $type or $type = '8bit';
3800              
3801             my $width = defined $opts{width} ? $opts{width}
3802 12 50       31 : $self->getwidth() - $opts{x};
3803              
3804 12         14 my $count;
3805 12 100       42 if ($type eq '8bit') {
    100          
    100          
3806             $count = i_psamp($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3807 5         31 $_[$data_index], $opts{offset}, $width);
3808             }
3809             elsif ($type eq 'float') {
3810             $count = i_psampf($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3811 5         57 $_[$data_index], $opts{offset}, $width);
3812             }
3813             elsif ($type =~ /^([0-9]+)bit$/) {
3814 1         4 my $bits = $1;
3815              
3816 1 50       5 unless (ref $_[$data_index]) {
3817 0         0 $self->_set_error("setsamples: data must be an array ref for type not 8bit or float");
3818 0         0 return;
3819             }
3820              
3821             $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3822             $opts{channels}, $_[$data_index], $opts{offset},
3823 1         72 $width);
3824             }
3825             else {
3826 1         3 $self->_set_error('setsamples: type parameter invalid');
3827 1         4 return;
3828             }
3829              
3830 11 100       38 unless (defined $count) {
3831 4         10 $self->_set_error(Imager->_error_as_msg);
3832 4         20 return;
3833             }
3834              
3835 7         31 return $count;
3836             }
3837              
3838             # make an identity matrix of the given size
3839             sub _identity {
3840 2     2   6 my ($size) = @_;
3841              
3842 2         7 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
  8         20  
3843 2         8 for my $c (0 .. ($size-1)) {
3844 8         12 $matrix->[$c][$c] = 1;
3845             }
3846 2         5 return $matrix;
3847             }
3848              
3849             # general function to convert an image
3850             sub convert {
3851 18     18 0 103 my ($self, %opts) = @_;
3852 18         27 my $matrix;
3853              
3854 18 100       40 $self->_valid_image("convert")
3855             or return;
3856              
3857 17 100       50 unless (defined wantarray) {
3858 1         4 my @caller = caller;
3859 1         13 warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3860 1         49 return;
3861             }
3862              
3863             # the user can either specify a matrix or preset
3864             # the matrix overrides the preset
3865 16 100       42 if (!exists($opts{matrix})) {
3866 14 50       32 unless (exists($opts{preset})) {
3867 0         0 $self->{ERRSTR} = "convert() needs a matrix or preset";
3868 0         0 return;
3869             }
3870             else {
3871 14 100 100     157 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
    100 33        
    50 33        
    50 66        
    100          
    50          
    100          
    50          
3872             # convert to greyscale, keeping the alpha channel if any
3873 3 50       7 if ($self->getchannels == 3) {
    0          
3874 3         8 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3875             }
3876             elsif ($self->getchannels == 4) {
3877             # preserve the alpha channel
3878 0         0 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3879             [ 0, 0, 0, 1 ] ];
3880             }
3881             else {
3882             # an identity
3883 0         0 $matrix = _identity($self->getchannels);
3884             }
3885             }
3886             elsif ($opts{preset} eq 'noalpha') {
3887             # strip the alpha channel
3888 1 50 33     4 if ($self->getchannels == 2 or $self->getchannels == 4) {
3889 1         3 $matrix = _identity($self->getchannels);
3890 1         3 pop(@$matrix); # lose the alpha entry
3891             }
3892             else {
3893 0         0 $matrix = _identity($self->getchannels);
3894             }
3895             }
3896             elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3897             # extract channel 0
3898 0         0 $matrix = [ [ 1 ] ];
3899             }
3900             elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3901 0         0 $matrix = [ [ 0, 1 ] ];
3902             }
3903             elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3904 3         7 $matrix = [ [ 0, 0, 1 ] ];
3905             }
3906             elsif ($opts{preset} eq 'alpha') {
3907 0 0 0     0 if ($self->getchannels == 2 or $self->getchannels == 4) {
3908 0         0 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3909             }
3910             else {
3911             # the alpha is just 1
3912 0         0 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3913             }
3914             }
3915             elsif ($opts{preset} eq 'rgb') {
3916 6 50       11 if ($self->getchannels == 1) {
    0          
3917 6         17 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3918             }
3919             elsif ($self->getchannels == 2) {
3920             # preserve the alpha channel
3921 0         0 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3922             }
3923             else {
3924 0         0 $matrix = _identity($self->getchannels);
3925             }
3926             }
3927             elsif ($opts{preset} eq 'addalpha') {
3928 1 50       5 if ($self->getchannels == 1) {
    50          
3929 0         0 $matrix = _identity(2);
3930             }
3931             elsif ($self->getchannels == 3) {
3932 1         4 $matrix = _identity(4);
3933             }
3934             else {
3935 0         0 $matrix = _identity($self->getchannels);
3936             }
3937             }
3938             else {
3939 0         0 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3940 0         0 return undef;
3941             }
3942             }
3943             }
3944             else {
3945 2         3 $matrix = $opts{matrix};
3946             }
3947              
3948 16         42 my $new = Imager->new;
3949 16         6517 $new->{IMG} = i_convert($self->{IMG}, $matrix);
3950 16 100       69 unless ($new->{IMG}) {
3951             # most likely a bad matrix
3952 1         32 i_push_error(0, "convert");
3953 1         5 $self->{ERRSTR} = _error_as_msg();
3954 1         4 return undef;
3955             }
3956 15         65 return $new;
3957             }
3958              
3959             # combine channels from multiple input images, a class method
3960             sub combine {
3961 14     14 0 2663 my ($class, %opts) = @_;
3962              
3963 14         24 my $src = delete $opts{src};
3964 14 100       29 unless ($src) {
3965 1         5 $class->_set_error("src parameter missing");
3966 1         3 return;
3967             }
3968 13         16 my @imgs;
3969 13         13 my $index = 0;
3970 13         18 for my $img (@$src) {
3971 21 100       25 unless (eval { $img->isa("Imager") }) {
  21         65  
3972 1         3 $class->_set_error("src must contain image objects");
3973 1         4 return;
3974             }
3975 20 100       33 unless ($img->_valid_image("combine")) {
3976 1         3 $Imager::ERRSTR = $img->{ERRSTR} . " (src->[$index])";
3977 1         4 return;
3978             }
3979 19         33 push @imgs, $img->{IMG};
3980             }
3981 11         12 my $result;
3982 11 100       20 if (my $channels = delete $opts{channels}) {
3983 4         721 $result = i_combine(\@imgs, $channels);
3984             }
3985             else {
3986 7         4091 $result = i_combine(\@imgs);
3987             }
3988 11 100       32 unless ($result) {
3989 4         9 $class->_set_error($class->_error_as_msg);
3990 4         17 return;
3991             }
3992              
3993 7         15 my $img = $class->new;
3994 7         8 $img->{IMG} = $result;
3995              
3996 7         19 return $img;
3997             }
3998              
3999              
4000             # general function to map an image through lookup tables
4001              
4002             sub map {
4003 6     6 0 116 my ($self, %opts) = @_;
4004 6         18 my @chlist = qw( red green blue alpha );
4005              
4006 6 100       17 $self->_valid_image("map")
4007             or return;
4008              
4009 5 100       15 if (!exists($opts{'maps'})) {
4010             # make maps from channel maps
4011 1         2 my $chnum;
4012 1         4 for $chnum (0..$#chlist) {
4013 4 100       12 if (exists $opts{$chlist[$chnum]}) {
    50          
4014 3         5 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
4015             } elsif (exists $opts{'all'}) {
4016 0         0 $opts{'maps'}[$chnum] = $opts{'all'};
4017             }
4018             }
4019             }
4020 5 50 33     26 if ($opts{'maps'} and $self->{IMG}) {
4021 5         2496 i_map($self->{IMG}, $opts{'maps'} );
4022             }
4023 5         35 return $self;
4024             }
4025              
4026             sub difference {
4027 7     7 0 718 my ($self, %opts) = @_;
4028              
4029 7 100       17 $self->_valid_image("difference")
4030             or return;
4031              
4032 6 100       19 defined $opts{mindist} or $opts{mindist} = 0;
4033              
4034             defined $opts{other}
4035 6 50       12 or return $self->_set_error("No 'other' parameter supplied");
4036 6 100       12 unless ($opts{other}->_valid_image("difference")) {
4037 1         4 $self->_set_error($opts{other}->errstr . " (other image)");
4038 1         6 return;
4039             }
4040              
4041 5         12 my $result = Imager->new;
4042             $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
4043             $opts{mindist})
4044 5 50       2247 or return $self->_set_error($self->_error_as_msg());
4045              
4046 5         21 return $result;
4047             }
4048              
4049             sub rgb_difference {
4050 1     1 0 9 my ($self, %opts) = @_;
4051              
4052 1 50       3 $self->_valid_image("rgb_difference")
4053             or return;
4054              
4055             defined $opts{other}
4056 1 50       4 or return $self->_set_error("No 'other' parameter supplied");
4057 1 50       2 unless ($opts{other}->_valid_image("rgb_difference")) {
4058 0         0 $self->_set_error($opts{other}->errstr . " (other image)");
4059 0         0 return;
4060             }
4061              
4062 1         5 my $result = Imager->new;
4063             $result->{IMG} = i_rgbdiff_image($self->{IMG}, $opts{other}{IMG})
4064 1 50       191 or return $self->_set_error($self->_error_as_msg());
4065              
4066 1         4 return $result;
4067             }
4068              
4069             # destructive border - image is shrunk by one pixel all around
4070              
4071             sub border {
4072 0     0 0 0 my ($self,%opts)=@_;
4073 0         0 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
4074 0         0 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
4075             }
4076              
4077              
4078             # Get the width of an image
4079              
4080             sub getwidth {
4081 2042     2042 0 28863 my $self = shift;
4082              
4083 2042 100       3177 $self->_valid_image("getwidth")
4084             or return;
4085              
4086 2041         6736 return i_img_get_width($self->{IMG});
4087             }
4088              
4089             # Get the height of an image
4090              
4091             sub getheight {
4092 1739     1739 0 3092 my $self = shift;
4093              
4094 1739 100       2369 $self->_valid_image("getheight")
4095             or return;
4096              
4097 1738         5838 return i_img_get_height($self->{IMG});
4098             }
4099              
4100             # Get number of channels in an image
4101              
4102             sub getchannels {
4103 649     649 0 2506 my $self = shift;
4104              
4105 649 100       908 $self->_valid_image("getchannels")
4106             or return;
4107              
4108 648         1944 return i_img_getchannels($self->{IMG});
4109             }
4110              
4111             my @model_names = qw(unknown gray graya rgb rgba);
4112              
4113             sub colormodel {
4114 7     7 0 985 my ($self, %opts) = @_;
4115              
4116 7 100       15 $self->_valid_image("colormodel")
4117             or return;
4118              
4119 6         22 my $model = i_img_color_model($self->{IMG});
4120              
4121 6 100       32 return $opts{numeric} ? $model : $model_names[$model];
4122             }
4123              
4124             sub colorchannels {
4125 6     6 0 425 my ($self) = @_;
4126              
4127 6 100       10 $self->_valid_image("colorchannels")
4128             or return;
4129              
4130 5         24 return i_img_color_channels($self->{IMG});
4131             }
4132              
4133             sub alphachannel {
4134 6     6 0 10 my ($self) = @_;
4135              
4136 6 100       13 $self->_valid_image("alphachannel")
4137             or return;
4138              
4139 5         28 return scalar(i_img_alpha_channel($self->{IMG}));
4140             }
4141              
4142             # Get channel mask
4143              
4144             sub getmask {
4145 2     2 0 9 my $self = shift;
4146              
4147 2 100       8 $self->_valid_image("getmask")
4148             or return;
4149              
4150 1         8 return i_img_getmask($self->{IMG});
4151             }
4152              
4153             # Set channel mask
4154              
4155             sub setmask {
4156 28     28 0 1378 my $self = shift;
4157 28         68 my %opts = @_;
4158              
4159 28 50       1790 warnings::warnif("Imager::channelmask", "setmask: image channel masks are deprecated")
4160             if $] >= 5.014;
4161              
4162 28 100       121 $self->_valid_image("setmask")
4163             or return;
4164              
4165 27 50       62 unless (defined $opts{mask}) {
4166 0         0 $self->_set_error("mask parameter required");
4167 0         0 return;
4168             }
4169              
4170 27         92 i_img_setmask( $self->{IMG} , $opts{mask} );
4171              
4172 27         506 1;
4173             }
4174              
4175             # Get number of colors in an image
4176              
4177             sub getcolorcount {
4178 10     10 0 38 my $self=shift;
4179 10         25 my %opts=('maxcolors'=>2**30,@_);
4180              
4181 10 100       21 $self->_valid_image("getcolorcount")
4182             or return;
4183              
4184 9         63424 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
4185 9 100       107 return ($rc==-1? undef : $rc);
4186             }
4187              
4188             # Returns a reference to a hash. The keys are colour named (packed) and the
4189             # values are the number of pixels in this colour.
4190             sub getcolorusagehash {
4191 4     4 0 909 my $self = shift;
4192              
4193 4 100       7 $self->_valid_image("getcolorusagehash")
4194             or return;
4195              
4196 3         9 my %opts = ( maxcolors => 2**30, @_ );
4197 3         5 my $max_colors = $opts{maxcolors};
4198 3 50 33     12 unless (defined $max_colors && $max_colors > 0) {
4199 0         0 $self->_set_error('maxcolors must be a positive integer');
4200 0         0 return;
4201             }
4202              
4203 3         5 my $channels= $self->getchannels;
4204             # We don't want to look at the alpha channel, because some gifs using it
4205             # doesn't define it for every colour (but only for some)
4206 3 50 33     10 $channels -= 1 if $channels == 2 or $channels == 4;
4207 3         4 my %color_use;
4208 3         5 my $height = $self->getheight;
4209 3         8 for my $y (0 .. $height - 1) {
4210 126         370 my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
4211 126         353 while (length $colors) {
4212 6300         8104 $color_use{ substr($colors, 0, $channels, '') }++;
4213             }
4214 126 100       249 keys %color_use > $max_colors
4215             and return;
4216             }
4217 2         10 return \%color_use;
4218             }
4219              
4220             # This will return a ordered array of the colour usage. Kind of the sorted
4221             # version of the values of the hash returned by getcolorusagehash.
4222             # You might want to add safety checks and change the names, etc...
4223             sub getcolorusage {
4224 6     6 0 1809 my $self = shift;
4225              
4226 6 100       14 $self->_valid_image("getcolorusage")
4227             or return;
4228              
4229 5         13 my %opts = ( maxcolors => 2**30, @_ );
4230 5         7 my $max_colors = $opts{maxcolors};
4231 5 50 33     18 unless (defined $max_colors && $max_colors > 0) {
4232 0         0 $self->_set_error('maxcolors must be a positive integer');
4233 0         0 return;
4234             }
4235              
4236 5         5314 return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
4237             }
4238              
4239             # draw string to an image
4240              
4241             sub string {
4242 1     1 0 8 my $self = shift;
4243              
4244 1 50       6 $self->_valid_image("string")
4245             or return;
4246              
4247 0         0 my %input=('x'=>0, 'y'=>0, @_);
4248 0 0       0 defined($input{string}) or $input{string} = $input{text};
4249              
4250 0 0       0 unless(defined $input{string}) {
4251 0         0 $self->{ERRSTR}="missing required parameter 'string'";
4252 0         0 return;
4253             }
4254              
4255 0 0       0 unless($input{font}) {
4256 0         0 $self->{ERRSTR}="missing required parameter 'font'";
4257 0         0 return;
4258             }
4259              
4260 0 0       0 unless ($input{font}->draw(image=>$self, %input)) {
4261 0         0 return;
4262             }
4263              
4264 0         0 return $self;
4265             }
4266              
4267             sub align_string {
4268 1     1 0 3 my $self = shift;
4269              
4270 1         2 my $img;
4271 1 50       4 if (ref $self) {
4272 1 50       3 $self->_valid_image("align_string")
4273             or return;
4274              
4275 0         0 $img = $self;
4276             }
4277             else {
4278 0         0 $img = undef;
4279             }
4280              
4281 0         0 my %input=('x'=>0, 'y'=>0, @_);
4282             defined $input{string}
4283 0 0       0 or $input{string} = $input{text};
4284              
4285 0 0       0 unless(exists $input{string}) {
4286 0         0 $self->_set_error("missing required parameter 'string'");
4287 0         0 return;
4288             }
4289              
4290 0 0       0 unless($input{font}) {
4291 0         0 $self->_set_error("missing required parameter 'font'");
4292 0         0 return;
4293             }
4294              
4295 0         0 my @result;
4296 0 0       0 unless (@result = $input{font}->align(image=>$img, %input)) {
4297 0         0 return;
4298             }
4299              
4300 0 0       0 return wantarray ? @result : $result[0];
4301             }
4302              
4303             my @file_limit_names = qw/width height bytes/;
4304              
4305             sub set_file_limits {
4306 25     25 0 507 shift;
4307              
4308 25         90 my %opts = @_;
4309 25         90 my %values;
4310            
4311 25 100       72 if ($opts{reset}) {
4312 23         97 @values{@file_limit_names} = (0) x @file_limit_names;
4313             }
4314             else {
4315 2         19 @values{@file_limit_names} = i_get_image_file_limits();
4316             }
4317              
4318 25         77 for my $key (keys %values) {
4319 75 100       159 defined $opts{$key} and $values{$key} = $opts{$key};
4320             }
4321              
4322 25         223 i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
4323             }
4324              
4325             sub get_file_limits {
4326 5     5 0 79097 i_get_image_file_limits();
4327             }
4328              
4329             my @check_args = qw(width height channels sample_size);
4330              
4331             sub check_file_limits {
4332 11     11 0 27 my $class = shift;
4333              
4334 11         49 my %opts =
4335             (
4336             channels => 3,
4337             sample_size => 1,
4338             @_,
4339             );
4340              
4341 11 100 100     75 if ($opts{sample_size} && $opts{sample_size} eq 'float') {
4342 1         5 $opts{sample_size} = length(pack("d", 0));
4343             }
4344              
4345 11         28 for my $name (@check_args) {
4346 38 100       103 unless (defined $opts{$name}) {
4347 1         5 $class->_set_error("check_file_limits: $name must be defined");
4348 1         5 return;
4349             }
4350 37 100       76 unless ($opts{$name} == int($opts{$name})) {
4351 1         5 $class->_set_error("check_file_limits: $name must be a positive integer");
4352 1         5 return;
4353             }
4354             }
4355              
4356 9         144 my $result = i_int_check_image_file_limits(@opts{@check_args});
4357 9 100       21 unless ($result) {
4358 6         22 $class->_set_error($class->_error_as_msg());
4359             }
4360              
4361 9         42 return $result;
4362             }
4363              
4364             # Shortcuts that can be exported
4365              
4366 277     277 0 98981 sub newcolor { Imager::Color->new(@_); }
4367 0     0 0 0 sub newfont { Imager::Font->new(@_); }
4368             sub NCF {
4369 33     33 0 13783 require Imager::Color::Float;
4370 33         119 return Imager::Color::Float->new(@_);
4371             }
4372              
4373             *NC=*newcolour=*newcolor;
4374             *NF=*newfont;
4375              
4376             *open=\&read;
4377             *circle=\&arc;
4378              
4379              
4380             #### Utility routines
4381              
4382             sub errstr {
4383 331 100   331 1 9492 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
4384             }
4385              
4386             sub _set_error {
4387 203     203   377 my ($self, $msg) = @_;
4388              
4389 203 100       406 if (ref $self) {
4390 169         271 $self->{ERRSTR} = $msg;
4391             }
4392             else {
4393 34         66 $ERRSTR = $msg;
4394             }
4395 203         421 return;
4396             }
4397              
4398             # Default guess for the type of an image from extension
4399              
4400             my @simple_types = qw(png tga gif raw ico cur xpm mng jng ilbm pcx psd eps webp xwd xpm dng ras qoi jxl);
4401              
4402             my %ext_types =
4403             (
4404             ( map { $_ => $_ } @simple_types ),
4405             tiff => "tiff",
4406             tif => "tiff",
4407             pbm => "pnm",
4408             pgm => "pnm",
4409             ppm => "pnm",
4410             pnm => "pnm", # technically wrong, but historically it works in Imager
4411             jpeg => "jpeg",
4412             jpg => "jpeg",
4413             bmp => "bmp",
4414             dib => "bmp",
4415             rgb => "sgi",
4416             bw => "sgi",
4417             sgi => "sgi",
4418             fit => "fits",
4419             fits => "fits",
4420             rle => "utah",
4421             avifs => "avif", # AVIF image sequence
4422             avif => "avif",
4423             );
4424              
4425             sub def_guess_type {
4426 121     121 0 7182 my $name=lc(shift);
4427              
4428 121 50       879 my ($ext) = $name =~ /\.([^.]+)$/
4429             or return;
4430              
4431 121         322 my $type = $ext_types{$ext};
4432 121 100       253 unless ($type) {
4433 2         4 $type = $ext_types{lc $ext};
4434             }
4435              
4436 121 50 66     344 if (!defined $type && $ext =~ /\A[a-zA-Z0-9_]{2,}\z/) {
4437             # maybe a reasonable assumption
4438 0         0 $type = lc $ext;
4439             }
4440              
4441 121         257 return $type;
4442             }
4443              
4444             sub add_type_extensions {
4445 1     1 0 417 my ($class, $type, @exts) = @_;
4446              
4447 1         8 for my $ext (@exts) {
4448 1 50       9 exists $ext_types{lc $ext} or $ext_types{lc $ext} = lc $type;
4449             }
4450 1         3 1;
4451             }
4452              
4453             sub combines {
4454 1     1 0 9 return @combine_types;
4455             }
4456              
4457             # get the minimum of a list
4458              
4459             sub _min {
4460 1389     1389   1606 my $mx=shift;
4461 1389 50       1835 for(@_) { if ($_<$mx) { $mx=$_; }}
  1389         2258  
  0         0  
4462 1389         1861 return $mx;
4463             }
4464              
4465             # get the maximum of a list
4466              
4467             sub _max {
4468 1139     1139   1268 my $mx=shift;
4469 1139 100       1350 for(@_) { if ($_>$mx) { $mx=$_; }}
  1139         1597  
  1120         1257  
4470 1139         1281 return $mx;
4471             }
4472              
4473             # string stuff for iptc headers
4474              
4475             sub _clean {
4476 0     0   0 my($str)=$_[0];
4477 0         0 $str = substr($str,3);
4478 0         0 $str =~ s/[\n\r]//g;
4479 0         0 $str =~ s/\s+/ /g;
4480 0         0 $str =~ s/^\s//;
4481 0         0 $str =~ s/\s$//;
4482 0         0 return $str;
4483             }
4484              
4485             # A little hack to parse iptc headers.
4486              
4487             sub parseiptc {
4488 0     0 0 0 my $self=shift;
4489 0         0 my(@sar,$item,@ar);
4490 0         0 my($caption,$photogr,$headln,$credit);
4491              
4492 0         0 my $str=$self->{IPTCRAW};
4493              
4494 0 0       0 defined $str
4495             or return;
4496              
4497 0         0 @ar=split(/8BIM/,$str);
4498              
4499 0         0 my $i=0;
4500 0         0 foreach (@ar) {
4501 0 0       0 if (/^\004\004/) {
4502 0         0 @sar=split(/\034\002/);
4503 0         0 foreach $item (@sar) {
4504 0 0       0 if ($item =~ m/^x/) {
4505 0         0 $caption = _clean($item);
4506 0         0 $i++;
4507             }
4508 0 0       0 if ($item =~ m/^P/) {
4509 0         0 $photogr = _clean($item);
4510 0         0 $i++;
4511             }
4512 0 0       0 if ($item =~ m/^i/) {
4513 0         0 $headln = _clean($item);
4514 0         0 $i++;
4515             }
4516 0 0       0 if ($item =~ m/^n/) {
4517 0         0 $credit = _clean($item);
4518 0         0 $i++;
4519             }
4520             }
4521             }
4522             }
4523 0         0 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
4524             }
4525              
4526             sub Inline {
4527             # Inline added a new argument at the beginning
4528 0     0 0 0 my $lang = $_[-1];
4529              
4530 0 0 0     0 $lang eq 'C' || $lang eq 'CPP'
4531             or die "Only C or C++ (CPP) language supported";
4532              
4533 0         0 require Imager::ExtUtils;
4534 0         0 return Imager::ExtUtils->inline_config;
4535             }
4536              
4537             # threads shouldn't try to close raw Imager objects
4538 0     0   0 sub Imager::ImgRaw::CLONE_SKIP { 1 }
4539              
4540             sub preload {
4541             # this serves two purposes:
4542             # - a class method to load the file support modules included with Imager
4543             # (or were included, once the library dependent modules are split out)
4544             # - something for Module::ScanDeps to analyze
4545             # https://rt.cpan.org/Ticket/Display.html?id=6566
4546 1     1 0 77 local $@;
4547 1         5 local @INC = @INC;
4548 1 50       6 pop @INC if $INC[-1] eq '.';
4549 1         2 eval { require Imager::File::GIF };
  1         112  
4550 1         4 eval { require Imager::File::JPEG };
  1         91  
4551 1         3 eval { require Imager::File::PNG };
  1         88  
4552 1         4 eval { require Imager::File::SGI };
  1         355  
4553 1         3 eval { require Imager::File::TIFF };
  1         100  
4554 1         4 eval { require Imager::File::ICO };
  1         320  
4555 1         3 eval { require Imager::Font::W32 };
  1         109  
4556 1         4 eval { require Imager::Font::FT2 };
  1         89  
4557 1         3 eval { require Imager::Font::T1 };
  1         89  
4558 1         3 eval { require Imager::Color::Table };
  1         406  
4559              
4560 1         13 1;
4561             }
4562              
4563             package Imager::IO;
4564 58     58   28368 use IO::Seekable;
  58         353232  
  58         11718  
4565              
4566             sub new_fh {
4567 19     19   6505 my ($class, $fh) = @_;
4568              
4569 19 100       57 if (tied(*$fh)) {
4570             return $class->new_cb
4571             (
4572             sub {
4573 2     2   2015 local $\;
4574              
4575 2         9 return print $fh $_[0];
4576             },
4577             sub {
4578 2     2   522 my $tmp;
4579 2         10 my $count = CORE::read $fh, $tmp, $_[1];
4580 2 50       31 defined $count
4581             or return undef;
4582 2 100       9 $count
4583             or return "";
4584 1         4 return $tmp;
4585             },
4586             sub {
4587 2 50 33 2   33 if ($_[1] != SEEK_CUR || $_[0] != 0) {
4588 2 50       9 unless (CORE::seek $fh, $_[0], $_[1]) {
4589 0         0 return -1;
4590             }
4591             }
4592              
4593 2         26 return tell $fh;
4594             },
4595             undef,
4596 1         128 );
4597             }
4598             else {
4599 18         1917 return $class->_new_perlio($fh);
4600             }
4601             }
4602              
4603             # backward compatibility for %formats
4604             package Imager::FORMATS;
4605 58     58   432 use strict;
  58         132  
  58         1450  
4606 58     58   285 use constant IX_FORMATS => 0;
  58         138  
  58         5390  
4607 58     58   355 use constant IX_LIST => 1;
  58         106  
  58         2888  
4608 58     58   315 use constant IX_INDEX => 2;
  58         118  
  58         2505  
4609 58     58   323 use constant IX_CLASSES => 3;
  58         117  
  58         41121  
4610              
4611             sub TIEHASH {
4612 58     58   147 my ($class, $formats, $classes) = @_;
4613              
4614 58         282 return bless [ $formats, [ ], 0, $classes ], $class;
4615             }
4616              
4617             sub _check {
4618 75     75   134 my ($self, $key) = @_;
4619              
4620 75         310 (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4621 75         120 my $value;
4622             my $error;
4623 75         130 my $loaded = Imager::_load_file($file, \$error);
4624 75 50       146 if ($loaded) {
4625 0         0 $value = 1;
4626             }
4627             else {
4628 75 50       220 if ($error =~ /^Can't locate /) {
4629 75         144 $error = "Can't locate $file";
4630             }
4631 75         154 $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
4632 75         127 $value = undef;
4633             }
4634 75         112 $self->[IX_FORMATS]{$key} = $value;
4635              
4636 75         220 return $value;
4637             }
4638              
4639             sub FETCH {
4640 19     19   450 my ($self, $key) = @_;
4641              
4642 19 100       118 exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4643              
4644 9 100       45 $self->[IX_CLASSES]{$key} or return undef;
4645              
4646 5         19 return $self->_check($key);
4647             }
4648              
4649             sub STORE {
4650 0     0   0 die "%Imager::formats is not user monifiable";
4651             }
4652              
4653             sub DELETE {
4654 0     0   0 die "%Imager::formats is not user monifiable";
4655             }
4656              
4657             sub CLEAR {
4658 0     0   0 die "%Imager::formats is not user monifiable";
4659             }
4660              
4661             sub EXISTS {
4662 0     0   0 my ($self, $key) = @_;
4663              
4664 0 0       0 if (exists $self->[IX_FORMATS]{$key}) {
4665 0 0       0 my $value = $self->[IX_FORMATS]{$key}
4666             or return;
4667 0         0 return 1;
4668             }
4669              
4670 0 0       0 $self->_check($key) or return 1==0;
4671              
4672 0         0 return 1==1;
4673             }
4674              
4675             sub FIRSTKEY {
4676 33     33   151 my ($self) = @_;
4677              
4678 33 100       43 unless (@{$self->[IX_LIST]}) {
  33         136  
4679             # full populate it
4680 10         38 @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4681 10         23 keys %{$self->[IX_FORMATS]};
  10         81  
4682              
4683 10         22 for my $key (keys %{$self->[IX_CLASSES]}) {
  10         87  
4684 70 50       141 $self->[IX_FORMATS]{$key} and next;
4685             $self->_check($key)
4686 70 50       139 and push @{$self->[IX_LIST]}, $key;
  0         0  
4687             }
4688             }
4689              
4690 33 50       50 @{$self->[IX_LIST]} or return;
  33         81  
4691 33         71 $self->[IX_INDEX] = 1;
4692 33         114 return $self->[IX_LIST][0];
4693             }
4694              
4695             sub NEXTKEY {
4696 165     165   221 my ($self) = @_;
4697              
4698 165 100       170 $self->[IX_INDEX] < @{$self->[IX_LIST]}
  165         371  
4699             or return;
4700              
4701 132         280 return $self->[IX_LIST][$self->[IX_INDEX]++];
4702             }
4703              
4704             sub SCALAR {
4705 0     0     my ($self) = @_;
4706              
4707 0           return scalar @{$self->[IX_LIST]};
  0            
4708             }
4709              
4710             1;
4711             __END__