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