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