1.008 release
[imager.git] / Imager.pm
CommitLineData
02d1d628
AMH
1package Imager;
2
02d1d628 3use strict;
50c75381 4use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR %OPCODES $I2P $FORMATGUESS $warn_obsolete);
02d1d628 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 }
b5bbf161 147 $VERSION = '1.008';
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
1045 return i_img_make_palette($quant, map $_->{IMG}, @images);
1046}
1047
3bcba6df 1048# convert a paletted (or any image) to an 8-bit/channel RGB image
faa9b3e7
TC
1049sub to_rgb8 {
1050 my $self = shift;
faa9b3e7 1051
34b3f7e6
TC
1052 unless (defined wantarray) {
1053 my @caller = caller;
b13bf7e8 1054 warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
34b3f7e6
TC
1055 return;
1056 }
1057
1136f089 1058 $self->_valid_image("to_rgb8")
3bcba6df
TC
1059 or return;
1060
1061 my $result = Imager->new;
1062 unless ($result->{IMG} = i_img_to_rgb($self->{IMG})) {
1063 $self->_set_error(Imager->_error_as_msg());
1064 return;
faa9b3e7
TC
1065 }
1066
1067 return $result;
1068}
1069
3bcba6df 1070# convert a paletted (or any image) to a 16-bit/channel RGB image
837a4b43
TC
1071sub to_rgb16 {
1072 my $self = shift;
837a4b43
TC
1073
1074 unless (defined wantarray) {
1075 my @caller = caller;
3bcba6df 1076 warn "to_rgb16() called in void context - to_rgb16() returns the converted image at $caller[1] line $caller[2]\n";
837a4b43
TC
1077 return;
1078 }
1079
1136f089 1080 $self->_valid_image("to_rgb16")
3bcba6df
TC
1081 or return;
1082
1083 my $result = Imager->new;
1084 unless ($result->{IMG} = i_img_to_rgb16($self->{IMG})) {
1085 $self->_set_error(Imager->_error_as_msg());
1086 return;
837a4b43
TC
1087 }
1088
1089 return $result;
1090}
1091
bfe6ba3f
TC
1092# convert a paletted (or any image) to an double/channel RGB image
1093sub to_rgb_double {
1094 my $self = shift;
1095
1096 unless (defined wantarray) {
1097 my @caller = caller;
1098 warn "to_rgb16() called in void context - to_rgb_double() returns the converted image at $caller[1] line $caller[2]\n";
1099 return;
1100 }
1101
1136f089 1102 $self->_valid_image("to_rgb_double")
bfe6ba3f
TC
1103 or return;
1104
1105 my $result = Imager->new;
1106 unless ($result->{IMG} = i_img_to_drgb($self->{IMG})) {
1107 $self->_set_error(Imager->_error_as_msg());
1108 return;
1109 }
1110
1111 return $result;
1112}
1113
faa9b3e7
TC
1114sub addcolors {
1115 my $self = shift;
1116 my %opts = (colors=>[], @_);
1117
1136f089
TC
1118 $self->_valid_image("addcolors")
1119 or return -1;
32b97571
TC
1120
1121 my @colors = @{$opts{colors}}
1122 or return undef;
faa9b3e7 1123
32b97571
TC
1124 for my $color (@colors) {
1125 $color = _color($color);
1126 unless ($color) {
1127 $self->_set_error($Imager::ERRSTR);
1128 return;
1129 }
1130 }
1131
1132 return i_addcolors($self->{IMG}, @colors);
faa9b3e7
TC
1133}
1134
1135sub setcolors {
1136 my $self = shift;
1137 my %opts = (start=>0, colors=>[], @_);
faa9b3e7 1138
1136f089
TC
1139 $self->_valid_image("setcolors")
1140 or return;
32b97571
TC
1141
1142 my @colors = @{$opts{colors}}
1143 or return undef;
1144
1145 for my $color (@colors) {
1146 $color = _color($color);
1147 unless ($color) {
1148 $self->_set_error($Imager::ERRSTR);
1149 return;
1150 }
1151 }
1152
1153 return i_setcolors($self->{IMG}, $opts{start}, @colors);
faa9b3e7
TC
1154}
1155
1156sub getcolors {
1157 my $self = shift;
1158 my %opts = @_;
1136f089
TC
1159
1160 $self->_valid_image("getcolors")
1161 or return;
1162
faa9b3e7
TC
1163 if (!exists $opts{start} && !exists $opts{count}) {
1164 # get them all
1165 $opts{start} = 0;
1166 $opts{count} = $self->colorcount;
1167 }
1168 elsif (!exists $opts{count}) {
1169 $opts{count} = 1;
1170 }
1171 elsif (!exists $opts{start}) {
1172 $opts{start} = 0;
1173 }
1136f089
TC
1174
1175 return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
faa9b3e7
TC
1176}
1177
1178sub colorcount {
1136f089
TC
1179 my ($self) = @_;
1180
1181 $self->_valid_image("colorcount")
1182 or return -1;
1183
1184 return i_colorcount($self->{IMG});
faa9b3e7
TC
1185}
1186
1187sub maxcolors {
1136f089
TC
1188 my $self = shift;
1189
1190 $self->_valid_image("maxcolors")
1191 or return -1;
1192
1193 i_maxcolors($self->{IMG});
faa9b3e7
TC
1194}
1195
1196sub findcolor {
1197 my $self = shift;
1198 my %opts = @_;
faa9b3e7 1199
1136f089
TC
1200 $self->_valid_image("findcolor")
1201 or return;
1202
1203 unless ($opts{color}) {
1204 $self->_set_error("findcolor: no color parameter");
1205 return;
1206 }
1207
1208 my $color = _color($opts{color})
1209 or return;
1210
1211 return i_findcolor($self->{IMG}, $color);
faa9b3e7
TC
1212}
1213
1214sub bits {
1215 my $self = shift;
1136f089
TC
1216
1217 $self->_valid_image("bits")
1218 or return;
1219
1220 my $bits = i_img_bits($self->{IMG});
af3c2450
TC
1221 if ($bits && $bits == length(pack("d", 1)) * 8) {
1222 $bits = 'double';
1223 }
1136f089 1224 return $bits;
faa9b3e7
TC
1225}
1226
1227sub type {
1228 my $self = shift;
1136f089
TC
1229
1230 $self->_valid_image("type")
1231 or return;
1232
1233 return i_img_type($self->{IMG}) ? "paletted" : "direct";
faa9b3e7
TC
1234}
1235
1236sub virtual {
1237 my $self = shift;
1136f089
TC
1238
1239 $self->_valid_image("virtual")
1240 or return;
1241
1242 return i_img_virtual($self->{IMG});
faa9b3e7
TC
1243}
1244
bd8052a6
TC
1245sub is_bilevel {
1246 my ($self) = @_;
1247
1136f089
TC
1248 $self->_valid_image("is_bilevel")
1249 or return;
bd8052a6
TC
1250
1251 return i_img_is_monochrome($self->{IMG});
1252}
1253
faa9b3e7
TC
1254sub tags {
1255 my ($self, %opts) = @_;
1256
1136f089
TC
1257 $self->_valid_image("tags")
1258 or return;
faa9b3e7
TC
1259
1260 if (defined $opts{name}) {
1261 my @result;
1262 my $start = 0;
1263 my $found;
1264 while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1265 push @result, (i_tags_get($self->{IMG}, $found))[1];
1266 $start = $found+1;
1267 }
1268 return wantarray ? @result : $result[0];
1269 }
1270 elsif (defined $opts{code}) {
1271 my @result;
1272 my $start = 0;
1273 my $found;
1274 while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1275 push @result, (i_tags_get($self->{IMG}, $found))[1];
1276 $start = $found+1;
1277 }
1278 return @result;
1279 }
1280 else {
1281 if (wantarray) {
1282 return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1283 }
1284 else {
1285 return i_tags_count($self->{IMG});
1286 }
1287 }
1288}
1289
1290sub addtag {
1291 my $self = shift;
1292 my %opts = @_;
1293
1136f089
TC
1294 $self->_valid_image("addtag")
1295 or return;
1296
faa9b3e7
TC
1297 if ($opts{name}) {
1298 if (defined $opts{value}) {
1299 if ($opts{value} =~ /^\d+$/) {
1300 # add as a number
1301 return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1302 }
1303 else {
1304 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1305 }
1306 }
1307 elsif (defined $opts{data}) {
1308 # force addition as a string
1309 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1310 }
1311 else {
1312 $self->{ERRSTR} = "No value supplied";
1313 return undef;
1314 }
1315 }
1316 elsif ($opts{code}) {
1317 if (defined $opts{value}) {
1318 if ($opts{value} =~ /^\d+$/) {
1319 # add as a number
1320 return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1321 }
1322 else {
1323 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1324 }
1325 }
1326 elsif (defined $opts{data}) {
1327 # force addition as a string
1328 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1329 }
1330 else {
1331 $self->{ERRSTR} = "No value supplied";
1332 return undef;
1333 }
1334 }
1335 else {
1336 return undef;
1337 }
1338}
1339
1340sub deltag {
1341 my $self = shift;
1342 my %opts = @_;
1343
1136f089
TC
1344 $self->_valid_image("deltag")
1345 or return 0;
faa9b3e7 1346
9d540150
TC
1347 if (defined $opts{'index'}) {
1348 return i_tags_delete($self->{IMG}, $opts{'index'});
faa9b3e7
TC
1349 }
1350 elsif (defined $opts{name}) {
1351 return i_tags_delbyname($self->{IMG}, $opts{name});
1352 }
1353 elsif (defined $opts{code}) {
1354 return i_tags_delbycode($self->{IMG}, $opts{code});
1355 }
1356 else {
1357 $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1358 return 0;
1359 }
02d1d628
AMH
1360}
1361
97c4effc
TC
1362sub settag {
1363 my ($self, %opts) = @_;
1364
1136f089
TC
1365 $self->_valid_image("settag")
1366 or return;
1367
97c4effc
TC
1368 if ($opts{name}) {
1369 $self->deltag(name=>$opts{name});
1370 return $self->addtag(name=>$opts{name}, value=>$opts{value});
1371 }
1372 elsif (defined $opts{code}) {
1373 $self->deltag(code=>$opts{code});
1374 return $self->addtag(code=>$opts{code}, value=>$opts{value});
1375 }
1376 else {
1377 return undef;
1378 }
1379}
1380
10461f9a
TC
1381
1382sub _get_reader_io {
84e51293 1383 my ($self, $input) = @_;
10461f9a 1384
e7ff1cf7
TC
1385 if ($input->{io}) {
1386 return $input->{io}, undef;
1387 }
84e51293 1388 elsif ($input->{fd}) {
10461f9a
TC
1389 return io_new_fd($input->{fd});
1390 }
1391 elsif ($input->{fh}) {
52d990d6 1392 unless (Scalar::Util::openhandle($input->{fh})) {
10461f9a
TC
1393 $self->_set_error("Handle in fh option not opened");
1394 return;
1395 }
52d990d6 1396 return Imager::IO->new_fh($input->{fh});
10461f9a
TC
1397 }
1398 elsif ($input->{file}) {
1399 my $file = IO::File->new($input->{file}, "r");
1400 unless ($file) {
1401 $self->_set_error("Could not open $input->{file}: $!");
1402 return;
1403 }
1404 binmode $file;
1405 return (io_new_fd(fileno($file)), $file);
1406 }
1407 elsif ($input->{data}) {
1408 return io_new_buffer($input->{data});
1409 }
1410 elsif ($input->{callback} || $input->{readcb}) {
84e51293
AMH
1411 if (!$input->{seekcb}) {
1412 $self->_set_error("Need a seekcb parameter");
10461f9a
TC
1413 }
1414 if ($input->{maxbuffer}) {
1415 return io_new_cb($input->{writecb},
1416 $input->{callback} || $input->{readcb},
1417 $input->{seekcb}, $input->{closecb},
1418 $input->{maxbuffer});
1419 }
1420 else {
1421 return io_new_cb($input->{writecb},
1422 $input->{callback} || $input->{readcb},
1423 $input->{seekcb}, $input->{closecb});
1424 }
1425 }
1426 else {
1427 $self->_set_error("file/fd/fh/data/callback parameter missing");
1428 return;
1429 }
1430}
1431
1432sub _get_writer_io {
5970bd39 1433 my ($self, $input) = @_;
10461f9a 1434
6d5c85a2
TC
1435 my $buffered = exists $input->{buffered} ? $input->{buffered} : 1;
1436
1437 my $io;
1438 my @extras;
e7ff1cf7 1439 if ($input->{io}) {
6d5c85a2 1440 $io = $input->{io};
e7ff1cf7
TC
1441 }
1442 elsif ($input->{fd}) {
6d5c85a2 1443 $io = io_new_fd($input->{fd});
10461f9a
TC
1444 }
1445 elsif ($input->{fh}) {
52d990d6 1446 unless (Scalar::Util::openhandle($input->{fh})) {
10461f9a
TC
1447 $self->_set_error("Handle in fh option not opened");
1448 return;
1449 }
52d990d6 1450 $io = Imager::IO->new_fh($input->{fh});
10461f9a
TC
1451 }
1452 elsif ($input->{file}) {
1453 my $fh = new IO::File($input->{file},"w+");
1454 unless ($fh) {
1455 $self->_set_error("Could not open file $input->{file}: $!");
1456 return;
1457 }
1458 binmode($fh) or die;
6d5c85a2
TC
1459 $io = io_new_fd(fileno($fh));
1460 push @extras, $fh;
10461f9a
TC
1461 }
1462 elsif ($input->{data}) {
6d5c85a2 1463 $io = io_new_bufchain();
10461f9a
TC
1464 }
1465 elsif ($input->{callback} || $input->{writecb}) {
6d5c85a2
TC
1466 if ($input->{maxbuffer} && $input->{maxbuffer} == 1) {
1467 $buffered = 0;
10461f9a 1468 }
6d5c85a2
TC
1469 $io = io_new_cb($input->{callback} || $input->{writecb},
1470 $input->{readcb},
1471 $input->{seekcb}, $input->{closecb});
10461f9a
TC
1472 }
1473 else {
1474 $self->_set_error("file/fd/fh/data/callback parameter missing");
1475 return;
1476 }
6d5c85a2
TC
1477
1478 unless ($buffered) {
1479 $io->set_buffered(0);
1480 }
1481
1482 return ($io, @extras);
10461f9a
TC
1483}
1484
02d1d628
AMH
1485# Read an image from file
1486
1487sub read {
1488 my $self = shift;
1489 my %input=@_;
02d1d628
AMH
1490
1491 if (defined($self->{IMG})) {
faa9b3e7
TC
1492 # let IIM_DESTROY do the destruction, since the image may be
1493 # referenced from elsewhere
1494 #i_img_destroy($self->{IMG});
02d1d628
AMH
1495 undef($self->{IMG});
1496 }
1497
84e51293
AMH
1498 my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1499
5970bd39
TC
1500 my $type = $input{'type'};
1501 unless ($type) {
1502 $type = i_test_format_probe($IO, -1);
66614d6e 1503 }
84e51293 1504
4f21e06e
TC
1505 if ($input{file} && !$type) {
1506 # guess the type
1507 $type = $FORMATGUESS->($input{file});
1508 }
1509
5970bd39 1510 unless ($type) {
4f21e06e
TC
1511 my $msg = "type parameter missing and it couldn't be determined from the file contents";
1512 $input{file} and $msg .= " or file name";
1513 $self->_set_error($msg);
10461f9a
TC
1514 return undef;
1515 }
02d1d628 1516
5970bd39 1517 _reader_autoload($type);
53a6bbd4 1518
5970bd39
TC
1519 if ($readers{$type} && $readers{$type}{single}) {
1520 return $readers{$type}{single}->($self, $IO, %input);
53a6bbd4
TC
1521 }
1522
5970bd39 1523 unless ($formats_low{$type}) {
f245645a 1524 my $read_types = join ', ', sort Imager->read_types();
5970bd39 1525 $self->_set_error("format '$type' not supported - formats $read_types available for reading - $reader_load_errors{$type}");
66614d6e
TC
1526 return;
1527 }
1528
d87dc9a4
TC
1529 my $allow_incomplete = $input{allow_incomplete};
1530 defined $allow_incomplete or $allow_incomplete = 0;
9c106321 1531
5970bd39 1532 if ( $type eq 'pnm' ) {
d87dc9a4 1533 $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
2fe0b227 1534 if ( !defined($self->{IMG}) ) {
2691d220
TC
1535 $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1536 return undef;
790923a4 1537 }
2fe0b227
AMH
1538 $self->{DEBUG} && print "loading a pnm file\n";
1539 return $self;
1540 }
790923a4 1541
5970bd39 1542 if ( $type eq 'bmp' ) {
d87dc9a4 1543 $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
2fe0b227
AMH
1544 if ( !defined($self->{IMG}) ) {
1545 $self->{ERRSTR}=$self->_error_as_msg();
1546 return undef;
10461f9a 1547 }
2fe0b227
AMH
1548 $self->{DEBUG} && print "loading a bmp file\n";
1549 }
10461f9a 1550
5970bd39 1551 if ( $type eq 'tga' ) {
2fe0b227
AMH
1552 $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1553 if ( !defined($self->{IMG}) ) {
1554 $self->{ERRSTR}=$self->_error_as_msg();
1555 return undef;
895dbd34 1556 }
2fe0b227
AMH
1557 $self->{DEBUG} && print "loading a tga file\n";
1558 }
02d1d628 1559
5970bd39 1560 if ( $type eq 'raw' ) {
500888da
TC
1561 unless ( $input{xsize} && $input{ysize} ) {
1562 $self->_set_error('missing xsize or ysize parameter for raw');
2fe0b227 1563 return undef;
895dbd34
AMH
1564 }
1565
500888da
TC
1566 my $interleave = _first($input{raw_interleave}, $input{interleave});
1567 unless (defined $interleave) {
1568 my @caller = caller;
1569 warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
1570 $interleave = 1;
1571 }
1572 my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
1573 my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
1574
2fe0b227 1575 $self->{IMG} = i_readraw_wiol( $IO,
500888da
TC
1576 $input{xsize},
1577 $input{ysize},
1578 $data_ch,
1579 $store_ch,
1580 $interleave);
2fe0b227 1581 if ( !defined($self->{IMG}) ) {
5f8f8e17 1582 $self->{ERRSTR}=$self->_error_as_msg();
2fe0b227 1583 return undef;
dd55acc8 1584 }
2fe0b227 1585 $self->{DEBUG} && print "loading a raw file\n";
02d1d628 1586 }
2fe0b227 1587
02d1d628 1588 return $self;
02d1d628
AMH
1589}
1590
53a6bbd4
TC
1591sub register_reader {
1592 my ($class, %opts) = @_;
1593
1594 defined $opts{type}
1595 or die "register_reader called with no type parameter\n";
1596
1597 my $type = $opts{type};
1598
1599 defined $opts{single} || defined $opts{multiple}
1600 or die "register_reader called with no single or multiple parameter\n";
1601
1602 $readers{$type} = { };
1603 if ($opts{single}) {
1604 $readers{$type}{single} = $opts{single};
1605 }
1606 if ($opts{multiple}) {
1607 $readers{$type}{multiple} = $opts{multiple};
1608 }
1609
1610 return 1;
1611}
1612
2b405c9e
TC
1613sub register_writer {
1614 my ($class, %opts) = @_;
1615
1616 defined $opts{type}
1617 or die "register_writer called with no type parameter\n";
1618
1619 my $type = $opts{type};
1620
1621 defined $opts{single} || defined $opts{multiple}
1622 or die "register_writer called with no single or multiple parameter\n";
1623
1624 $writers{$type} = { };
1625 if ($opts{single}) {
1626 $writers{$type}{single} = $opts{single};
1627 }
1628 if ($opts{multiple}) {
1629 $writers{$type}{multiple} = $opts{multiple};
1630 }
1631
1632 return 1;
1633}
1634
f245645a
TC
1635sub read_types {
1636 my %types =
1637 (
1638 map { $_ => 1 }
1639 keys %readers,
1640 grep($file_formats{$_}, keys %formats),
1641 qw(ico sgi), # formats not handled directly, but supplied with Imager
1642 );
1643
1644 return keys %types;
1645}
1646
1647sub write_types {
1648 my %types =
1649 (
1650 map { $_ => 1 }
1651 keys %writers,
1652 grep($file_formats{$_}, keys %formats),
1653 qw(ico sgi), # formats not handled directly, but supplied with Imager
1654 );
1655
1656 return keys %types;
1657}
1658
5970bd39
TC
1659sub _load_file {
1660 my ($file, $error) = @_;
1661
1662 if ($attempted_to_load{$file}) {
1663 if ($file_load_errors{$file}) {
1664 $$error = $file_load_errors{$file};
1665 return 0;
1666 }
1667 else {
1668 return 1;
1669 }
1670 }
1671 else {
1672 local $SIG{__DIE__};
1673 my $loaded = eval {
b1736e02
TC
1674 local @INC = @INC;
1675 pop @INC if $INC[-1] eq '.';
5970bd39
TC
1676 ++$attempted_to_load{$file};
1677 require $file;
1678 return 1;
1679 };
1680 if ($loaded) {
1681 return 1;
1682 }
1683 else {
38742a13 1684 my $work = $@ || "Unknown error";
5970bd39
TC
1685 chomp $work;
1686 $work =~ s/\n?Compilation failed in require at .*Imager\.pm line .*\z//m;
1687 $work =~ s/\n/\\n/g;
38742a13 1688 $work =~ s/\s*\.?\z/ loading $file/;
5970bd39
TC
1689 $file_load_errors{$file} = $work;
1690 $$error = $work;
1691 return 0;
1692 }
1693 }
1694}
1695
53a6bbd4
TC
1696# probes for an Imager::File::whatever module
1697sub _reader_autoload {
1698 my $type = shift;
1699
1d7e3124 1700 return if $formats_low{$type} || $readers{$type};
53a6bbd4
TC
1701
1702 return unless $type =~ /^\w+$/;
1703
1704 my $file = "Imager/File/\U$type\E.pm";
1705
5970bd39
TC
1706 my $error;
1707 my $loaded = _load_file($file, \$error);
1708 if (!$loaded && $error =~ /^Can't locate /) {
1709 my $filer = "Imager/File/\U$type\EReader.pm";
1710 $loaded = _load_file($filer, \$error);
1711 if ($error =~ /^Can't locate /) {
1712 $error = "Can't locate $file or $filer";
2b405c9e
TC
1713 }
1714 }
5970bd39
TC
1715 unless ($loaded) {
1716 $reader_load_errors{$type} = $error;
1717 }
2b405c9e
TC
1718}
1719
1720# probes for an Imager::File::whatever module
1721sub _writer_autoload {
1722 my $type = shift;
1723
5970bd39 1724 return if $formats_low{$type} || $writers{$type};
2b405c9e
TC
1725
1726 return unless $type =~ /^\w+$/;
1727
1728 my $file = "Imager/File/\U$type\E.pm";
1729
5970bd39
TC
1730 my $error;
1731 my $loaded = _load_file($file, \$error);
1732 if (!$loaded && $error =~ /^Can't locate /) {
1733 my $filew = "Imager/File/\U$type\EWriter.pm";
1734 $loaded = _load_file($filew, \$error);
1735 if ($error =~ /^Can't locate /) {
1736 $error = "Can't locate $file or $filew";
2b405c9e 1737 }
53a6bbd4 1738 }
5970bd39
TC
1739 unless ($loaded) {
1740 $writer_load_errors{$type} = $error;
1741 }
53a6bbd4
TC
1742}
1743
97c4effc
TC
1744sub _fix_gif_positions {
1745 my ($opts, $opt, $msg, @imgs) = @_;
2fe0b227 1746
97c4effc
TC
1747 my $positions = $opts->{'gif_positions'};
1748 my $index = 0;
1749 for my $pos (@$positions) {
1750 my ($x, $y) = @$pos;
1751 my $img = $imgs[$index++];
9d1c4956
TC
1752 $img->settag(name=>'gif_left', value=>$x);
1753 $img->settag(name=>'gif_top', value=>$y) if defined $y;
97c4effc
TC
1754 }
1755 $$msg .= "replaced with the gif_left and gif_top tags";
1756}
1757
1758my %obsolete_opts =
1759 (
1760 gif_each_palette=>'gif_local_map',
1761 interlace => 'gif_interlace',
1762 gif_delays => 'gif_delay',
1763 gif_positions => \&_fix_gif_positions,
1764 gif_loop_count => 'gif_loop',
1765 );
1766
6e4af7d4
TC
1767# options that should be converted to colors
1768my %color_opts = map { $_ => 1 } qw/i_background/;
1769
97c4effc
TC
1770sub _set_opts {
1771 my ($self, $opts, $prefix, @imgs) = @_;
1772
1773 for my $opt (keys %$opts) {
1774 my $tagname = $opt;
1775 if ($obsolete_opts{$opt}) {
1776 my $new = $obsolete_opts{$opt};
1777 my $msg = "Obsolete option $opt ";
1778 if (ref $new) {
1779 $new->($opts, $opt, \$msg, @imgs);
1780 }
1781 else {
1782 $msg .= "replaced with the $new tag ";
1783 $tagname = $new;
1784 }
1785 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1786 warn $msg if $warn_obsolete && $^W;
1787 }
1788 next unless $tagname =~ /^\Q$prefix/;
1789 my $value = $opts->{$opt};
6e4af7d4
TC
1790 if ($color_opts{$opt}) {
1791 $value = _color($value);
1792 unless ($value) {
1793 $self->_set_error($Imager::ERRSTR);
1794 return;
1795 }
1796 }
97c4effc
TC
1797 if (ref $value) {
1798 if (UNIVERSAL::isa($value, "Imager::Color")) {
1799 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1800 for my $img (@imgs) {
1801 $img->settag(name=>$tagname, value=>$tag);
1802 }
1803 }
1804 elsif (ref($value) eq 'ARRAY') {
1805 for my $i (0..$#$value) {
1806 my $val = $value->[$i];
1807 if (ref $val) {
1808 if (UNIVERSAL::isa($val, "Imager::Color")) {
1809 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1810 $i < @imgs and
1811 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1812 }
1813 else {
1814 $self->_set_error("Unknown reference type " . ref($value) .
1815 " supplied in array for $opt");
1816 return;
1817 }
1818 }
1819 else {
1820 $i < @imgs
1821 and $imgs[$i]->settag(name=>$tagname, value=>$val);
1822 }
1823 }
1824 }
1825 else {
1826 $self->_set_error("Unknown reference type " . ref($value) .
1827 " supplied for $opt");
1828 return;
1829 }
1830 }
1831 else {
1832 # set it as a tag for every image
1833 for my $img (@imgs) {
1834 $img->settag(name=>$tagname, value=>$value);
1835 }
1836 }
1837 }
1838
1839 return 1;
1840}
1841
02d1d628 1842# Write an image to file
02d1d628
AMH
1843sub write {
1844 my $self = shift;
2fe0b227
AMH
1845 my %input=(jpegquality=>75,
1846 gifquant=>'mc',
1847 lmdither=>6.0,
febba01f
AMH
1848 lmfixed=>[],
1849 idstring=>"",
1850 compress=>1,
1851 wierdpack=>0,
4c2d6970 1852 fax_fine=>1, @_);
10461f9a 1853 my $rc;
02d1d628 1854
1136f089
TC
1855 $self->_valid_image("write")
1856 or return;
1857
97c4effc
TC
1858 $self->_set_opts(\%input, "i_", $self)
1859 or return undef;
1860
5970bd39
TC
1861 my $type = $input{'type'};
1862 if (!$type and $input{file}) {
1863 $type = $FORMATGUESS->($input{file});
9d540150 1864 }
5970bd39 1865 unless ($type) {
9d540150
TC
1866 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1867 return undef;
1868 }
02d1d628 1869
5970bd39 1870 _writer_autoload($type);
02d1d628 1871
2b405c9e 1872 my ($IO, $fh);
5970bd39
TC
1873 if ($writers{$type} && $writers{$type}{single}) {
1874 ($IO, $fh) = $self->_get_writer_io(\%input)
2fe0b227 1875 or return undef;
febba01f 1876
5970bd39 1877 $writers{$type}{single}->($self, $IO, %input, type => $type)
2fe0b227 1878 or return undef;
2b405c9e
TC
1879 }
1880 else {
5970bd39 1881 if (!$formats_low{$type}) {
f245645a 1882 my $write_types = join ', ', sort Imager->write_types();
5970bd39 1883 $self->_set_error("format '$type' not supported - formats $write_types available for writing - $writer_load_errors{$type}");
2fe0b227 1884 return undef;
930c67c8 1885 }
2b405c9e 1886
5970bd39 1887 ($IO, $fh) = $self->_get_writer_io(\%input, $type)
2fe0b227 1888 or return undef;
5970bd39
TC
1889
1890 if ( $type eq 'pnm' ) {
2b405c9e
TC
1891 $self->_set_opts(\%input, "pnm_", $self)
1892 or return undef;
1893 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1894 $self->{ERRSTR} = $self->_error_as_msg();
1895 return undef;
1896 }
1897 $self->{DEBUG} && print "writing a pnm file\n";
5970bd39
TC
1898 }
1899 elsif ( $type eq 'raw' ) {
2b405c9e
TC
1900 $self->_set_opts(\%input, "raw_", $self)
1901 or return undef;
1902 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1903 $self->{ERRSTR} = $self->_error_as_msg();
1904 return undef;
1905 }
1906 $self->{DEBUG} && print "writing a raw file\n";
5970bd39
TC
1907 }
1908 elsif ( $type eq 'bmp' ) {
2b405c9e
TC
1909 $self->_set_opts(\%input, "bmp_", $self)
1910 or return undef;
1911 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
ae12796a 1912 $self->{ERRSTR} = $self->_error_as_msg;
2b405c9e
TC
1913 return undef;
1914 }
1915 $self->{DEBUG} && print "writing a bmp file\n";
5970bd39
TC
1916 }
1917 elsif ( $type eq 'tga' ) {
2b405c9e
TC
1918 $self->_set_opts(\%input, "tga_", $self)
1919 or return undef;
1920
1921 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1922 $self->{ERRSTR}=$self->_error_as_msg();
1923 return undef;
1924 }
1925 $self->{DEBUG} && print "writing a tga file\n";
1501d9b3 1926 }
02d1d628 1927 }
10461f9a 1928
2fe0b227
AMH
1929 if (exists $input{'data'}) {
1930 my $data = io_slurp($IO);
1931 if (!$data) {
1932 $self->{ERRSTR}='Could not slurp from buffer';
1933 return undef;
1934 }
1935 ${$input{data}} = $data;
1936 }
02d1d628
AMH
1937 return $self;
1938}
1939
1940sub write_multi {
1941 my ($class, $opts, @images) = @_;
1942
2b405c9e
TC
1943 my $type = $opts->{type};
1944
1945 if (!$type && $opts->{'file'}) {
1946 $type = $FORMATGUESS->($opts->{'file'});
10461f9a 1947 }
2b405c9e 1948 unless ($type) {
10461f9a
TC
1949 $class->_set_error('type parameter missing and not possible to guess from extension');
1950 return;
1951 }
1952 # translate to ImgRaw
1136f089
TC
1953 my $index = 1;
1954 for my $img (@images) {
9d264849
TC
1955 unless (ref $img && Scalar::Util::blessed($img) && $img->isa("Imager")) {
1956 $class->_set_error("write_multi: image $index is not an Imager image object");
1957 return;
1958 }
1136f089
TC
1959 unless ($img->_valid_image("write_multi")) {
1960 $class->_set_error($img->errstr . " (image $index)");
1961 return;
1962 }
1963 ++$index;
10461f9a 1964 }
97c4effc
TC
1965 $class->_set_opts($opts, "i_", @images)
1966 or return;
10461f9a 1967 my @work = map $_->{IMG}, @images;
2b405c9e
TC
1968
1969 _writer_autoload($type);
1970
1971 my ($IO, $file);
1972 if ($writers{$type} && $writers{$type}{multiple}) {
1973 ($IO, $file) = $class->_get_writer_io($opts, $type)
1974 or return undef;
1975
1976 $writers{$type}{multiple}->($class, $IO, $opts, @images)
1977 or return undef;
1978 }
1979 else {
1980 if (!$formats{$type}) {
f245645a
TC
1981 my $write_types = join ', ', sort Imager->write_types();
1982 $class->_set_error("format '$type' not supported - formats $write_types available for writing");
2b405c9e
TC
1983 return undef;
1984 }
1985
1986 ($IO, $file) = $class->_get_writer_io($opts, $type)
1987 or return undef;
1988
e5ee047b 1989 if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
02d1d628
AMH
1990 }
1991 else {
e7ff1cf7
TC
1992 if (@images == 1) {
1993 unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1994 return 1;
1995 }
1996 }
1997 else {
1998 $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1999 return 0;
2000 }
02d1d628
AMH
2001 }
2002 }
2b405c9e
TC
2003
2004 if (exists $opts->{'data'}) {
2005 my $data = io_slurp($IO);
2006 if (!$data) {
2007 Imager->_set_error('Could not slurp from buffer');
2008 return undef;
2009 }
2010 ${$opts->{data}} = $data;
02d1d628 2011 }
2b405c9e 2012 return 1;
02d1d628
AMH
2013}
2014
faa9b3e7
TC
2015# read multiple images from a file
2016sub read_multi {
2017 my ($class, %opts) = @_;
2018
53a6bbd4
TC
2019 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
2020 or return;
2021
2022 my $type = $opts{'type'};
2023 unless ($type) {
2024 $type = i_test_format_probe($IO, -1);
2025 }
2026
2027 if ($opts{file} && !$type) {
faa9b3e7 2028 # guess the type
53a6bbd4 2029 $type = $FORMATGUESS->($opts{file});
faa9b3e7 2030 }
53a6bbd4
TC
2031
2032 unless ($type) {
4f21e06e
TC
2033 my $msg = "type parameter missing and it couldn't be determined from the file contents";
2034 $opts{file} and $msg .= " or file name";
2035 Imager->_set_error($msg);
faa9b3e7
TC
2036 return;
2037 }
faa9b3e7 2038
53a6bbd4
TC
2039 _reader_autoload($type);
2040
2041 if ($readers{$type} && $readers{$type}{multiple}) {
2042 return $readers{$type}{multiple}->($IO, %opts);
2043 }
2044
8d46e5da
TC
2045 unless ($formats{$type}) {
2046 my $read_types = join ', ', sort Imager->read_types();
2047 Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
2048 return;
2049 }
2050
e5ee047b
TC
2051 my @imgs;
2052 if ($type eq 'pnm') {
2086be61 2053 @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
faa9b3e7 2054 }
e7ff1cf7
TC
2055 else {
2056 my $img = Imager->new;
2057 if ($img->read(%opts, io => $IO, type => $type)) {
2058 return ( $img );
2059 }
f245645a 2060 Imager->_set_error($img->errstr);
2086be61 2061 return;
e7ff1cf7 2062 }
faa9b3e7 2063
2086be61
TC
2064 if (!@imgs) {
2065 $ERRSTR = _error_as_msg();
faa9b3e7 2066 return;
2086be61
TC
2067 }
2068 return map {
2069 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
2070 } @imgs;
faa9b3e7
TC
2071}
2072
02d1d628
AMH
2073# Destroy an Imager object
2074
2075sub DESTROY {
2076 my $self=shift;
2077 # delete $instances{$self};
2078 if (defined($self->{IMG})) {
faa9b3e7
TC
2079 # the following is now handled by the XS DESTROY method for
2080 # Imager::ImgRaw object
2081 # Re-enabling this will break virtual images
2082 # tested for in t/t020masked.t
2083 # i_img_destroy($self->{IMG});
02d1d628
AMH
2084 undef($self->{IMG});
2085 } else {
2086# print "Destroy Called on an empty image!\n"; # why did I put this here??
2087 }
2088}
2089
2090# Perform an inplace filter of an image
2091# that is the image will be overwritten with the data
2092
2093sub filter {
2094 my $self=shift;
2095 my %input=@_;
2096 my %hsh;
1136f089
TC
2097
2098 $self->_valid_image("filter")
2099 or return;
02d1d628 2100
9d540150 2101 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
02d1d628 2102
9d540150 2103 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
02d1d628
AMH
2104 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2105 }
2106
9d540150
TC
2107 if ($filters{$input{'type'}}{names}) {
2108 my $names = $filters{$input{'type'}}{names};
6607600c
TC
2109 for my $name (keys %$names) {
2110 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2111 $input{$name} = $names->{$name}{$input{$name}};
2112 }
2113 }
2114 }
9d540150 2115 if (defined($filters{$input{'type'}}{defaults})) {
7327d4b0
TC
2116 %hsh=( image => $self->{IMG},
2117 imager => $self,
2118 %{$filters{$input{'type'}}{defaults}},
2119 %input );
02d1d628 2120 } else {
7327d4b0
TC
2121 %hsh=( image => $self->{IMG},
2122 imager => $self,
2123 %input );
02d1d628
AMH
2124 }
2125
9d540150 2126 my @cs=@{$filters{$input{'type'}}{callseq}};
02d1d628
AMH
2127
2128 for(@cs) {
2129 if (!defined($hsh{$_})) {
9d540150 2130 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
02d1d628
AMH
2131 }
2132 }
2133
109bec2d
TC
2134 eval {
2135 local $SIG{__DIE__}; # we don't want this processed by confess, etc
2136 &{$filters{$input{'type'}}{callsub}}(%hsh);
2137 };
2138 if ($@) {
2139 chomp($self->{ERRSTR} = $@);
2140 return;
2141 }
02d1d628
AMH
2142
2143 my @b=keys %hsh;
2144
2145 $self->{DEBUG} && print "callseq is: @cs\n";
2146 $self->{DEBUG} && print "matching callseq is: @b\n";
2147
2148 return $self;
2149}
2150
92bda632
TC
2151sub register_filter {
2152 my $class = shift;
2153 my %hsh = ( defaults => {}, @_ );
2154
2155 defined $hsh{type}
2156 or die "register_filter() with no type\n";
2157 defined $hsh{callsub}
2158 or die "register_filter() with no callsub\n";
2159 defined $hsh{callseq}
2160 or die "register_filter() with no callseq\n";
2161
2162 exists $filters{$hsh{type}}
2163 and return;
2164
2165 $filters{$hsh{type}} = \%hsh;
2166
2167 return 1;
2168}
2169
df9aaafb
TC
2170sub scale_calculate {
2171 my $self = shift;
02d1d628 2172
df9aaafb 2173 my %opts = ('type'=>'max', @_);
4f579313 2174
de470892
TC
2175 # none of these should be references
2176 for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2177 if (defined $opts{$name} && ref $opts{$name}) {
2178 $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2179 return;
2180 }
2181 }
2182
df9aaafb
TC
2183 my ($x_scale, $y_scale);
2184 my $width = $opts{width};
2185 my $height = $opts{height};
2186 if (ref $self) {
2187 defined $width or $width = $self->getwidth;
2188 defined $height or $height = $self->getheight;
ace46df2 2189 }
df9aaafb
TC
2190 else {
2191 unless (defined $width && defined $height) {
2192 $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2193 return;
2194 }
5168ca3a 2195 }
02d1d628 2196
658f724e
TC
2197 if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2198 $x_scale = $opts{'xscalefactor'};
2199 $y_scale = $opts{'yscalefactor'};
2200 }
2201 elsif ($opts{'xscalefactor'}) {
2202 $x_scale = $opts{'xscalefactor'};
2203 $y_scale = $opts{'scalefactor'} || $x_scale;
2204 }
2205 elsif ($opts{'yscalefactor'}) {
2206 $y_scale = $opts{'yscalefactor'};
2207 $x_scale = $opts{'scalefactor'} || $y_scale;
2208 }
2209 else {
2210 $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2211 }
2212
5168ca3a 2213 # work out the scaling
9d540150 2214 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
df9aaafb
TC
2215 my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2216 $opts{ypixels} / $height );
5168ca3a 2217 if ($opts{'type'} eq 'min') {
658f724e 2218 $x_scale = $y_scale = _min($xpix,$ypix);
5168ca3a
TC
2219 }
2220 elsif ($opts{'type'} eq 'max') {
658f724e
TC
2221 $x_scale = $y_scale = _max($xpix,$ypix);
2222 }
2223 elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2224 $x_scale = $xpix;
2225 $y_scale = $ypix;
5168ca3a
TC
2226 }
2227 else {
2228 $self->_set_error('invalid value for type parameter');
df9aaafb 2229 return;
5168ca3a
TC
2230 }
2231 } elsif ($opts{xpixels}) {
df9aaafb 2232 $x_scale = $y_scale = $opts{xpixels} / $width;
5168ca3a
TC
2233 }
2234 elsif ($opts{ypixels}) {
df9aaafb 2235 $x_scale = $y_scale = $opts{ypixels}/$height;
5168ca3a 2236 }
41c7d053
TC
2237 elsif ($opts{constrain} && ref $opts{constrain}
2238 && $opts{constrain}->can('constrain')) {
2239 # we've been passed an Image::Math::Constrain object or something
2240 # that looks like one
658f724e 2241 my $scalefactor;
4f579313 2242 (undef, undef, $scalefactor)
41c7d053 2243 = $opts{constrain}->constrain($self->getwidth, $self->getheight);
4f579313 2244 unless ($scalefactor) {
41c7d053 2245 $self->_set_error('constrain method failed on constrain parameter');
df9aaafb 2246 return;
41c7d053 2247 }
658f724e 2248 $x_scale = $y_scale = $scalefactor;
41c7d053 2249 }
02d1d628 2250
df9aaafb
TC
2251 my $new_width = int($x_scale * $width + 0.5);
2252 $new_width > 0 or $new_width = 1;
2253 my $new_height = int($y_scale * $height + 0.5);
2254 $new_height > 0 or $new_height = 1;
2255
2256 return ($x_scale, $y_scale, $new_width, $new_height);
2257
2258}
2259
2260# Scale an image to requested size and return the scaled version
2261
2262sub scale {
2263 my $self=shift;
2264 my %opts = (qtype=>'normal' ,@_);
2265 my $img = Imager->new();
2266 my $tmp = Imager->new();
2267
2268 unless (defined wantarray) {
2269 my @caller = caller;
2270 warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2271 return;
2272 }
2273
1136f089
TC
2274 $self->_valid_image("scale")
2275 or return;
df9aaafb
TC
2276
2277 my ($x_scale, $y_scale, $new_width, $new_height) =
2278 $self->scale_calculate(%opts)
2279 or return;
2280
02d1d628 2281 if ($opts{qtype} eq 'normal') {
658f724e 2282 $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
5168ca3a 2283 if ( !defined($tmp->{IMG}) ) {
de470892 2284 $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
5168ca3a
TC
2285 return undef;
2286 }
658f724e 2287 $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
5168ca3a 2288 if ( !defined($img->{IMG}) ) {
de470892 2289 $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
5168ca3a
TC
2290 return undef;
2291 }
2292
02d1d628
AMH
2293 return $img;
2294 }
5168ca3a 2295 elsif ($opts{'qtype'} eq 'preview') {
658f724e 2296 $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
5168ca3a
TC
2297 if ( !defined($img->{IMG}) ) {
2298 $self->{ERRSTR}='unable to scale image';
2299 return undef;
2300 }
02d1d628
AMH
2301 return $img;
2302 }
658f724e 2303 elsif ($opts{'qtype'} eq 'mixing') {
658f724e
TC
2304 $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2305 unless ($img->{IMG}) {
de470892 2306 $self->_set_error(Imager->_error_as_msg);
658f724e
TC
2307 return;
2308 }
2309 return $img;
2310 }
5168ca3a
TC
2311 else {
2312 $self->_set_error('invalid value for qtype parameter');
2313 return undef;
2314 }
02d1d628
AMH
2315}
2316
2317# Scales only along the X axis
2318
2319sub scaleX {
15327bf5
TC
2320 my $self = shift;
2321 my %opts = ( scalefactor=>0.5, @_ );
02d1d628 2322
34b3f7e6
TC
2323 unless (defined wantarray) {
2324 my @caller = caller;
2325 warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2326 return;
2327 }
2328
1136f089
TC
2329 $self->_valid_image("scaleX")
2330 or return;
02d1d628
AMH
2331
2332 my $img = Imager->new();
2333
15327bf5 2334 my $scalefactor = $opts{scalefactor};
02d1d628 2335
15327bf5
TC
2336 if ($opts{pixels}) {
2337 $scalefactor = $opts{pixels} / $self->getwidth();
2338 }
2339
2340 unless ($self->{IMG}) {
2341 $self->{ERRSTR}='empty input image';
2342 return undef;
2343 }
2344
2345 $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2346
2347 if ( !defined($img->{IMG}) ) {
2348 $self->{ERRSTR} = 'unable to scale image';
2349 return undef;
2350 }
02d1d628 2351
02d1d628
AMH
2352 return $img;
2353}
2354
2355# Scales only along the Y axis
2356
2357sub scaleY {
15327bf5
TC
2358 my $self = shift;
2359 my %opts = ( scalefactor => 0.5, @_ );
02d1d628 2360
34b3f7e6
TC
2361 unless (defined wantarray) {
2362 my @caller = caller;
2363 warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2364 return;
2365 }
2366
1136f089
TC
2367 $self->_valid_image("scaleY")
2368 or return;
02d1d628
AMH
2369
2370 my $img = Imager->new();
2371
15327bf5 2372 my $scalefactor = $opts{scalefactor};
02d1d628 2373
15327bf5
TC
2374 if ($opts{pixels}) {
2375 $scalefactor = $opts{pixels} / $self->getheight();
2376 }
2377
2378 unless ($self->{IMG}) {
2379 $self->{ERRSTR} = 'empty input image';
2380 return undef;
2381 }
2382 $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2383
2384 if ( !defined($img->{IMG}) ) {
2385 $self->{ERRSTR} = 'unable to scale image';
2386 return undef;
2387 }
02d1d628 2388
02d1d628
AMH
2389 return $img;
2390}
2391
02d1d628
AMH
2392# Transform returns a spatial transformation of the input image
2393# this moves pixels to a new location in the returned image.
2394# NOTE - should make a utility function to check transforms for
2395# stack overruns
2396
2397sub transform {
2398 my $self=shift;
02d1d628
AMH
2399 my %opts=@_;
2400 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2401
2402# print Dumper(\%opts);
2403# xopcopdes
2404
1136f089
TC
2405 $self->_valid_image("transform")
2406 or return;
2407
02d1d628
AMH
2408 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2409 if (!$I2P) {
b1736e02
TC
2410 {
2411 local @INC = @INC;
2412 pop @INC if $INC[-1] eq '.';
2413 eval ("use Affix::Infix2Postfix;");
2414 }
2415
02d1d628
AMH
2416 if ( $@ ) {
2417 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2418 return undef;
2419 }
2420 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2421 {op=>'-',trans=>'Sub'},
2422 {op=>'*',trans=>'Mult'},
2423 {op=>'/',trans=>'Div'},
9d540150 2424 {op=>'-','type'=>'unary',trans=>'u-'},
02d1d628 2425 {op=>'**'},
9d540150 2426 {op=>'func','type'=>'unary'}],
02d1d628
AMH
2427 'grouping'=>[qw( \( \) )],
2428 'func'=>[qw( sin cos )],
2429 'vars'=>[qw( x y )]
2430 );
2431 }
2432
2433 @xt=$I2P->translate($opts{'xexpr'});
2434 @yt=$I2P->translate($opts{'yexpr'});
2435
2436 $numre=$I2P->{'numre'};
2437 @pt=(0,0);
2438
2439 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2440 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2441 @{$opts{'parm'}}=@pt;
2442 }
2443
2444# print Dumper(\%opts);
2445
2446 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2447 $self->{ERRSTR}='transform: no xopcodes given.';
2448 return undef;
2449 }
2450
2451 @op=@{$opts{'xopcodes'}};
2452 for $iop (@op) {
2453 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2454 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2455 return undef;
2456 }
2457 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2458 }
2459
2460
2461# yopcopdes
2462
2463 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2464 $self->{ERRSTR}='transform: no yopcodes given.';
2465 return undef;
2466 }
2467
2468 @op=@{$opts{'yopcodes'}};
2469 for $iop (@op) {
2470 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2471 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2472 return undef;
2473 }
2474 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2475 }
2476
2477#parameters
2478
2479 if ( !exists $opts{'parm'}) {
2480 $self->{ERRSTR}='transform: no parameter arg given.';
2481 return undef;
2482 }
2483
2484# print Dumper(\@ropx);
2485# print Dumper(\@ropy);
2486# print Dumper(\@ropy);
2487
2488 my $img = Imager->new();
2489 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2490 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2491 return $img;
2492}
2493
2494
bf94b653
TC
2495sub transform2 {
2496 my ($opts, @imgs) = @_;
2497
2498 require "Imager/Expr.pm";
2499
2500 $opts->{variables} = [ qw(x y) ];
2501 my ($width, $height) = @{$opts}{qw(width height)};
2502 if (@imgs) {
1136f089
TC
2503 my $index = 1;
2504 for my $img (@imgs) {
2505 unless ($img->_valid_image("transform2")) {
2506 Imager->_set_error($img->errstr . " (input image $index)");
2507 return;
2508 }
2509 ++$index;
2510 }
2511
bf94b653
TC
2512 $width ||= $imgs[0]->getwidth();
2513 $height ||= $imgs[0]->getheight();
2514 my $img_num = 1;
2515 for my $img (@imgs) {
2516 $opts->{constants}{"w$img_num"} = $img->getwidth();
2517 $opts->{constants}{"h$img_num"} = $img->getheight();
2518 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2519 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2520 ++$img_num;
02d1d628 2521 }
02d1d628 2522 }
bf94b653
TC
2523 if ($width) {
2524 $opts->{constants}{w} = $width;
2525 $opts->{constants}{cx} = $width/2;
2526 }
2527 else {
2528 $Imager::ERRSTR = "No width supplied";
2529 return;
2530 }
2531 if ($height) {
2532 $opts->{constants}{h} = $height;
2533 $opts->{constants}{cy} = $height/2;
2534 }
2535 else {
2536 $Imager::ERRSTR = "No height supplied";
2537 return;
2538 }
2539 my $code = Imager::Expr->new($opts);
2540 if (!$code) {
2541 $Imager::ERRSTR = Imager::Expr::error();
2542 return;
2543 }
e5744e01
TC
2544 my $channels = $opts->{channels} || 3;
2545 unless ($channels >= 1 && $channels <= 4) {
2546 return Imager->_set_error("channels must be an integer between 1 and 4");
2547 }
9982a307 2548
bf94b653 2549 my $img = Imager->new();
e5744e01
TC
2550 $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2551 $channels, $code->code(),
bf94b653
TC
2552 $code->nregs(), $code->cregs(),
2553 [ map { $_->{IMG} } @imgs ]);
2554 if (!defined $img->{IMG}) {
2555 $Imager::ERRSTR = Imager->_error_as_msg();
2556 return;
2557 }
9982a307 2558
bf94b653 2559 return $img;
02d1d628
AMH
2560}
2561
02d1d628
AMH
2562sub rubthrough {
2563 my $self=shift;
9b1ec2b8 2564 my %opts= @_;
02d1d628 2565
1136f089
TC
2566 $self->_valid_image("rubthrough")
2567 or return;
2568
2569 unless ($opts{src} && $opts{src}->_valid_image("rubthrough")) {
2570 $self->{ERRSTR} = $opts{src}{ERRSTR} . ' (for src)';
2571 return;
e7b95388 2572 }
02d1d628 2573
71dc4a83
AMH
2574 %opts = (src_minx => 0,
2575 src_miny => 0,
2576 src_maxx => $opts{src}->getwidth(),
2577 src_maxy => $opts{src}->getheight(),
2578 %opts);
2579
9b1ec2b8
TC
2580 my $tx = $opts{tx};
2581 defined $tx or $tx = $opts{left};
2582 defined $tx or $tx = 0;
2583
2584 my $ty = $opts{ty};
2585 defined $ty or $ty = $opts{top};
2586 defined $ty or $ty = 0;
2587
2588 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
e7b95388
TC
2589 $opts{src_minx}, $opts{src_miny},
2590 $opts{src_maxx}, $opts{src_maxy})) {
2591 $self->_set_error($self->_error_as_msg());
faa9b3e7
TC
2592 return undef;
2593 }
9b1ec2b8 2594
02d1d628
AMH
2595 return $self;
2596}
2597
9b1ec2b8
TC
2598sub compose {
2599 my $self = shift;
2600 my %opts =
2601 (
2602 opacity => 1.0,
2603 mask_left => 0,
2604 mask_top => 0,
2605 @_
2606 );
2607
1136f089
TC
2608 $self->_valid_image("compose")
2609 or return;
9b1ec2b8
TC
2610
2611 unless ($opts{src}) {
2612 $self->_set_error("compose: src parameter missing");
2613 return;
2614 }
2615
1136f089
TC
2616 unless ($opts{src}->_valid_image("compose")) {
2617 $self->_set_error($opts{src}->errstr . " (for src)");
9b1ec2b8
TC
2618 return;
2619 }
2620 my $src = $opts{src};
2621
2622 my $left = $opts{left};
2623 defined $left or $left = $opts{tx};
2624 defined $left or $left = 0;
2625
2626 my $top = $opts{top};
2627 defined $top or $top = $opts{ty};
2628 defined $top or $top = 0;
2629
2630 my $src_left = $opts{src_left};
2631 defined $src_left or $src_left = $opts{src_minx};
2632 defined $src_left or $src_left = 0;
2633
2634 my $src_top = $opts{src_top};
2635 defined $src_top or $src_top = $opts{src_miny};
2636 defined $src_top or $src_top = 0;
2637
2638 my $width = $opts{width};
2639 if (!defined $width && defined $opts{src_maxx}) {
2640 $width = $opts{src_maxx} - $src_left;
2641 }
2642 defined $width or $width = $src->getwidth() - $src_left;
2643
2644 my $height = $opts{height};
2645 if (!defined $height && defined $opts{src_maxy}) {
2646 $height = $opts{src_maxy} - $src_top;
2647 }
2648 defined $height or $height = $src->getheight() - $src_top;
2649
2650 my $combine = $self->_combine($opts{combine}, 'normal');
2651
2652 if ($opts{mask}) {
1136f089
TC
2653 unless ($opts{mask}->_valid_image("compose")) {
2654 $self->_set_error($opts{mask}->errstr . " (for mask)");
9b1ec2b8
TC
2655 return;
2656 }
2657
2658 my $mask_left = $opts{mask_left};
2659 defined $mask_left or $mask_left = $opts{mask_minx};
2660 defined $mask_left or $mask_left = 0;
2661
2662 my $mask_top = $opts{mask_top};
2663 defined $mask_top or $mask_top = $opts{mask_miny};
2664 defined $mask_top or $mask_top = 0;
2665
618a3282 2666 unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
9b1ec2b8
TC
2667 $left, $top, $src_left, $src_top,
2668 $mask_left, $mask_top, $width, $height,
618a3282
TC
2669 $combine, $opts{opacity})) {
2670 $self->_set_error(Imager->_error_as_msg);
2671 return;
2672 }
9b1ec2b8
TC
2673 }
2674 else {
618a3282
TC
2675 unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2676 $width, $height, $combine, $opts{opacity})) {
2677 $self->_set_error(Imager->_error_as_msg);
2678 return;
2679 }
9b1ec2b8
TC
2680 }
2681
2682 return $self;
2683}
02d1d628 2684
142c26ff
AMH
2685sub flip {
2686 my $self = shift;
2687 my %opts = @_;
1136f089
TC
2688
2689 $self->_valid_image("flip")
2690 or return;
2691
9191e525 2692 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH
2693 my $dir;
2694 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2695 $dir = $xlate{$opts{'dir'}};
2696 return $self if i_flipxy($self->{IMG}, $dir);
2697 return ();
2698}
2699
faa9b3e7
TC
2700sub rotate {
2701 my $self = shift;
2702 my %opts = @_;
34b3f7e6
TC
2703
2704 unless (defined wantarray) {
2705 my @caller = caller;
2706 warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2707 return;
2708 }
2709
1136f089
TC
2710 $self->_valid_image("rotate")
2711 or return;
2712
faa9b3e7
TC
2713 if (defined $opts{right}) {
2714 my $degrees = $opts{right};
2715 if ($degrees < 0) {
2716 $degrees += 360 * int(((-$degrees)+360)/360);
2717 }
2718 $degrees = $degrees % 360;
2719 if ($degrees == 0) {
2720 return $self->copy();
2721 }
2722 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2723 my $result = Imager->new();
2724 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2725 return $result;
2726 }
2727 else {
2728 $self->{ERRSTR} = $self->_error_as_msg();
2729 return undef;
2730 }
2731 }
2732 else {
2733 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2734 return undef;
2735 }
2736 }
2737 elsif (defined $opts{radians} || defined $opts{degrees}) {
289d65f4 2738 my $amount = $opts{radians} || $opts{degrees} * 3.14159265358979 / 180;
faa9b3e7 2739
7f627571 2740 my $back = $opts{back};
faa9b3e7 2741 my $result = Imager->new;
7f627571
TC
2742 if ($back) {
2743 $back = _color($back);
2744 unless ($back) {
2745 $self->_set_error(Imager->errstr);
2746 return undef;
2747 }
2748
2749 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
0d3b936e
TC
2750 }
2751 else {
2752 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2753 }
2754 if ($result->{IMG}) {
faa9b3e7
TC
2755 return $result;
2756 }
2757 else {
2758 $self->{ERRSTR} = $self->_error_as_msg();
2759 return undef;
2760 }
2761 }
2762 else {
0d3b936e 2763 $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
faa9b3e7
TC
2764 return undef;
2765 }
2766}
2767
2768sub matrix_transform {
2769 my $self = shift;
2770 my %opts = @_;
2771
1136f089
TC
2772 $self->_valid_image("matrix_transform")
2773 or return;
2774
34b3f7e6
TC
2775 unless (defined wantarray) {
2776 my @caller = caller;
2777 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2778 return;
2779 }
2780
faa9b3e7
TC
2781 if ($opts{matrix}) {
2782 my $xsize = $opts{xsize} || $self->getwidth;
2783 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 2784
faa9b3e7 2785 my $result = Imager->new;
0d3b936e
TC
2786 if ($opts{back}) {
2787 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2788 $opts{matrix}, $opts{back})
2789 or return undef;
2790 }
2791 else {
2792 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2793 $opts{matrix})
2794 or return undef;
2795 }
faa9b3e7
TC
2796
2797 return $result;
2798 }
2799 else {
2800 $self->{ERRSTR} = "matrix parameter required";
2801 return undef;
2802 }
2803}
2804
2805# blame Leolo :)
2806*yatf = \&matrix_transform;
02d1d628
AMH
2807
2808# These two are supported for legacy code only
2809
2810sub i_color_new {
faa9b3e7 2811 return Imager::Color->new(@_);
02d1d628
AMH
2812}
2813
2814sub i_color_set {
faa9b3e7 2815 return Imager::Color::set(@_);
02d1d628
AMH
2816}
2817
02d1d628 2818# Draws a box between the specified corner points.
02d1d628
AMH
2819sub box {
2820 my $self=shift;
3b000586
TC
2821 my $raw = $self->{IMG};
2822
1136f089
TC
2823 $self->_valid_image("box")
2824 or return;
3b000586
TC
2825
2826 my %opts = @_;
02d1d628 2827
3b000586 2828 my ($xmin, $ymin, $xmax, $ymax);
02d1d628 2829 if (exists $opts{'box'}) {
3b000586
TC
2830 $xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2831 $xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2832 $ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2833 $ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2834 }
2835 else {
2836 defined($xmin = $opts{xmin}) or $xmin = 0;
2837 defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
2838 defined($ymin = $opts{ymin}) or $ymin = 0;
2839 defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
02d1d628
AMH
2840 }
2841
f1ac5027 2842 if ($opts{filled}) {
4dd88895
TC
2843 my $color = $opts{'color'};
2844
2845 if (defined $color) {
813d4d0a 2846 unless (_is_color_object($color)) {
4dd88895
TC
2847 $color = _color($color);
2848 unless ($color) {
2849 $self->{ERRSTR} = $Imager::ERRSTR;
2850 return;
2851 }
2852 }
3a9a4241 2853 }
4dd88895
TC
2854 else {
2855 $color = i_color_new(255,255,255,255);
2856 }
2857
7477ff14
TC
2858 if ($color->isa("Imager::Color")) {
2859 i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
2860 }
2861 else {
2862 i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
2863 }
f1ac5027
TC
2864 }
2865 elsif ($opts{fill}) {
2866 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2867 # assume it's a hash ref
2868 require 'Imager/Fill.pm';
141a6114
TC
2869 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2870 $self->{ERRSTR} = $Imager::ERRSTR;
2871 return undef;
2872 }
f1ac5027 2873 }
3b000586 2874 i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
f1ac5027 2875 }
cdd23610 2876 else {
4dd88895
TC
2877 my $color = $opts{'color'};
2878 if (defined $color) {
813d4d0a 2879 unless (_is_color_object($color)) {
4dd88895
TC
2880 $color = _color($color);
2881 unless ($color) {
2882 $self->{ERRSTR} = $Imager::ERRSTR;
2883 return;
2884 }
2885 }
2886 }
2887 else {
2888 $color = i_color_new(255, 255, 255, 255);
2889 }
3a9a4241 2890 unless ($color) {
cdd23610
AMH
2891 $self->{ERRSTR} = $Imager::ERRSTR;
2892 return;
3a9a4241 2893 }
3b000586 2894 i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
f1ac5027 2895 }
3b000586 2896
02d1d628
AMH
2897 return $self;
2898}
2899
02d1d628
AMH
2900sub arc {
2901 my $self=shift;
1136f089
TC
2902
2903 $self->_valid_image("arc")
2904 or return;
2905
40068b33
TC
2906 my $dflcl= [ 255, 255, 255, 255];
2907 my $good = 1;
2908 my %opts=
2909 (
2910 color=>$dflcl,
2911 'r'=>_min($self->getwidth(),$self->getheight())/3,
2912 'x'=>$self->getwidth()/2,
2913 'y'=>$self->getheight()/2,
2914 'd1'=>0, 'd2'=>361,
2915 filled => 1,
2916 @_,
2917 );
a8652edf
TC
2918 if ($opts{aa}) {
2919 if ($opts{fill}) {
2920 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2921 # assume it's a hash ref
2922 require 'Imager/Fill.pm';
2923 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2924 $self->{ERRSTR} = $Imager::ERRSTR;
2925 return;
2926 }
2927 }
bf18ef3a
TC
2928 if ($opts{d1} == 0 && $opts{d2} == 361) {
2929 i_circle_aa_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2930 $opts{fill}{fill});
2931 }
2932 else {
2933 i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2934 $opts{'d2'}, $opts{fill}{fill});
2935 }
a8652edf 2936 }
40068b33 2937 elsif ($opts{filled}) {
a8652edf
TC
2938 my $color = _color($opts{'color'});
2939 unless ($color) {
2940 $self->{ERRSTR} = $Imager::ERRSTR;
2941 return;
2942 }
2943 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2944 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2945 $color);
2946 }
2947 else {
2948 i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2949 $opts{'d1'}, $opts{'d2'}, $color);
569795e8 2950 }
f1ac5027 2951 }
40068b33
TC
2952 else {
2953 my $color = _color($opts{'color'});
2954 if ($opts{d2} - $opts{d1} >= 360) {
2955 $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2956 }
2957 else {
2958 $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2959 }
2960 }
f1ac5027
TC
2961 }
2962 else {
a8652edf
TC
2963 if ($opts{fill}) {
2964 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2965 # assume it's a hash ref
2966 require 'Imager/Fill.pm';
2967 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2968 $self->{ERRSTR} = $Imager::ERRSTR;
2969 return;
2970 }
2971 }
2972 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2973 $opts{'d2'}, $opts{fill}{fill});
0d321238
TC
2974 }
2975 else {
a8652edf
TC
2976 my $color = _color($opts{'color'});
2977 unless ($color) {
2978 $self->{ERRSTR} = $Imager::ERRSTR;
40068b33
TC
2979 return;
2980 }
2981 if ($opts{filled}) {
2982 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2983 $opts{'d1'}, $opts{'d2'}, $color);
2984 }
2985 else {
2986 if ($opts{d1} == 0 && $opts{d2} == 361) {
2987 $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2988 }
2989 else {
2990 $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2991 }
a8652edf 2992 }
0d321238 2993 }
f1ac5027 2994 }
40068b33
TC
2995 unless ($good) {
2996 $self->_set_error($self->_error_as_msg);
2997 return;
2998 }
f1ac5027 2999
02d1d628
AMH
3000 return $self;
3001}
3002
aa833c97
AMH
3003# Draws a line from one point to the other
3004# the endpoint is set if the endp parameter is set which it is by default.
3005# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH
3006
3007sub line {
3008 my $self=shift;
3009 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH
3010 my %opts=(color=>$dflcl,
3011 endp => 1,
3012 @_);
1136f089
TC
3013
3014 $self->_valid_image("line")
3015 or return;
02d1d628
AMH
3016
3017 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
3018 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
3019
3a9a4241 3020 my $color = _color($opts{'color'});
aa833c97
AMH
3021 unless ($color) {
3022 $self->{ERRSTR} = $Imager::ERRSTR;
3023 return;
3a9a4241 3024 }
aa833c97 3025
3a9a4241 3026 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 3027 if ($opts{antialias}) {
aa833c97 3028 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 3029 $color, $opts{endp});
02d1d628 3030 } else {
aa833c97
AMH
3031 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
3032 $color, $opts{endp});
02d1d628
AMH
3033 }
3034 return $self;
3035}
3036
3037# Draws a line between an ordered set of points - It more or less just transforms this
3038# into a list of lines.
3039
3040sub polyline {
3041 my $self=shift;
3042 my ($pt,$ls,@points);
3043 my $dflcl=i_color_new(0,0,0,0);
3044 my %opts=(color=>$dflcl,@_);
3045
1136f089
TC
3046 $self->_valid_image("polyline")
3047 or return;
02d1d628
AMH
3048
3049 if (exists($opts{points})) { @points=@{$opts{points}}; }
3050 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
3051 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
3052 }
3053
3054# print Dumper(\@points);
3055
3a9a4241
TC
3056 my $color = _color($opts{'color'});
3057 unless ($color) {
3058 $self->{ERRSTR} = $Imager::ERRSTR;
3059 return;
3060 }
3061 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH
3062 if ($opts{antialias}) {
3063 for $pt(@points) {
3a9a4241 3064 if (defined($ls)) {
b437ce0a 3065 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 3066 }
02d1d628
AMH
3067 $ls=$pt;
3068 }
3069 } else {
3070 for $pt(@points) {
3a9a4241 3071 if (defined($ls)) {
aa833c97 3072 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 3073 }
02d1d628
AMH
3074 $ls=$pt;
3075 }
3076 }
3077 return $self;
3078}
3079
d0e7bfee
AMH
3080sub polygon {
3081 my $self = shift;
3082 my ($pt,$ls,@points);
3083 my $dflcl = i_color_new(0,0,0,0);
3084 my %opts = (color=>$dflcl, @_);
3085
1136f089
TC
3086 $self->_valid_image("polygon")
3087 or return;
d0e7bfee
AMH
3088
3089 if (exists($opts{points})) {
3090 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
3091 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
3092 }
3093
3094 if (!exists $opts{'x'} or !exists $opts{'y'}) {
3095 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
3096 }
3097
0d80f37e
TC
3098 my $mode = _first($opts{mode}, 0);
3099
43c5dacb
TC
3100 if ($opts{'fill'}) {
3101 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
3102 # assume it's a hash ref
3103 require 'Imager/Fill.pm';
3104 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
3105 $self->{ERRSTR} = $Imager::ERRSTR;
3106 return undef;
3107 }
3108 }
3063ecbb
TC
3109 unless (i_poly_aa_cfill_m($self->{IMG}, $opts{'x'}, $opts{'y'},
3110 $mode, $opts{'fill'}{'fill'})) {
3111 return $self->_set_error($self->_error_as_msg);
3112 }
43c5dacb
TC
3113 }
3114 else {
3a9a4241
TC
3115 my $color = _color($opts{'color'});
3116 unless ($color) {
3117 $self->{ERRSTR} = $Imager::ERRSTR;
3063ecbb
TC
3118 return;
3119 }
3120 unless (i_poly_aa_m($self->{IMG}, $opts{'x'}, $opts{'y'}, $mode, $color)) {
3121 return $self->_set_error($self->_error_as_msg);
3a9a4241 3122 }
43c5dacb
TC
3123 }
3124
d0e7bfee
AMH
3125 return $self;
3126}
3127
0d80f37e
TC
3128sub polypolygon {
3129 my ($self, %opts) = @_;
3130
3131 $self->_valid_image("polypolygon")
3132 or return;
3133
3134 my $points = $opts{points};
3135 $points
3136 or return $self->_set_error("polypolygon: missing required points");
3137
3138 my $mode = _first($opts{mode}, "evenodd");
3139
3140 if ($opts{filled}) {
3141 my $color = _color(_first($opts{color}, [ 0, 0, 0, 0 ]))
3142 or return $self->_set_error($Imager::ERRSTR);
3143
3144 i_poly_poly_aa($self->{IMG}, $points, $mode, $color)
3145 or return $self->_set_error($self->_error_as_msg);
3146 }
3147 elsif ($opts{fill}) {
3148 my $fill = $opts{fill};
3149 $self->_valid_fill($fill, "polypolygon")
3150 or return;
3151
3152 i_poly_poly_aa_cfill($self->{IMG}, $points, $mode, $fill->{fill})
3153 or return $self->_set_error($self->_error_as_msg);
3154 }
3155 else {
3156 my $color = _color(_first($opts{color}, [ 0, 0, 0, 255 ]))
3157 or return $self->_set_error($Imager::ERRSTR);
3158
3159 my $rimg = $self->{IMG};
3160
3161 if (_first($opts{aa}, 1)) {
3162 for my $poly (@$points) {
3163 my $xp = $poly->[0];
3164 my $yp = $poly->[1];
3165 for my $i (0 .. $#$xp - 1) {
3166 i_line_aa($rimg, $xp->[$i], $yp->[$i], $xp->[$i+1], $yp->[$i+1],
3167 $color, 0);
3168 }
3169 i_line_aa($rimg, $xp->[$#$xp], $yp->[$#$yp], $xp->[0], $yp->[0],
3170 $color, 0);
3171 }
3172 }
3173 else {
3174 for my $poly (@$points) {
3175 my $xp = $poly->[0];
3176 my $yp = $poly->[1];
3177 for my $i (0 .. $#$xp - 1) {
3178 i_line($rimg, $xp->[$i], $yp->[$i], $xp->[$i+1], $yp->[$i+1],
3179 $color, 0);
3180 }
3181 i_line($rimg, $xp->[$#$xp], $yp->[$#$yp], $xp->[0], $yp->[0],
3182 $color, 0);
3183 }
3184 }
3185 }
3186
3187 return $self;
3188}
d0e7bfee
AMH
3189
3190# this the multipoint bezier curve
02d1d628
AMH
3191# this is here more for testing that actual usage since
3192# this is not a good algorithm. Usually the curve would be
3193# broken into smaller segments and each done individually.
3194
3195sub polybezier {
3196 my $self=shift;
3197 my ($pt,$ls,@points);
3198 my $dflcl=i_color_new(0,0,0,0);
3199 my %opts=(color=>$dflcl,@_);
3200
1136f089
TC
3201 $self->_valid_image("polybezier")
3202 or return;
02d1d628
AMH
3203
3204 if (exists $opts{points}) {
3205 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
3206 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
3207 }
3208
3209 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
3210 $self->{ERRSTR}='Missing or invalid points.';
3211 return;
3212 }
3213
3a9a4241
TC
3214 my $color = _color($opts{'color'});
3215 unless ($color) {
3216 $self->{ERRSTR} = $Imager::ERRSTR;
3217 return;
3218 }
3219 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH
3220 return $self;
3221}
3222
cc6483e0
TC
3223sub flood_fill {
3224 my $self = shift;
3225 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH
3226 my $rc;
3227
1136f089
TC
3228 $self->_valid_image("flood_fill")
3229 or return;
3230
9d540150 3231 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC
3232 $self->{ERRSTR} = "missing seed x and y parameters";
3233 return undef;
3234 }
07d70837 3235
3efb0915
TC
3236 if ($opts{border}) {
3237 my $border = _color($opts{border});
3238 unless ($border) {
3239 $self->_set_error($Imager::ERRSTR);
3240 return;
3241 }
3242 if ($opts{fill}) {
3243 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3244 # assume it's a hash ref
3245 require Imager::Fill;
3246 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3247 $self->{ERRSTR} = $Imager::ERRSTR;
3248 return;
3249 }
569795e8 3250 }
3efb0915
TC
3251 $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3252 $opts{fill}{fill}, $border);
3253 }
3254 else {
3255 my $color = _color($opts{'color'});
3256 unless ($color) {
3257 $self->{ERRSTR} = $Imager::ERRSTR;
3258 return;
3259 }
3260 $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3261 $color, $border);
3262 }
3263 if ($rc) {
3264 return $self;
3265 }
3266 else {
3267 $self->{ERRSTR} = $self->_error_as_msg();
3268 return;
cc6483e0 3269 }
cc6483e0
TC
3270 }
3271 else {
3efb0915
TC
3272 if ($opts{fill}) {
3273 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3274 # assume it's a hash ref
3275 require 'Imager/Fill.pm';
3276 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3277 $self->{ERRSTR} = $Imager::ERRSTR;
3278 return;
3279 }
3280 }
3281 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3282 }
3283 else {
3284 my $color = _color($opts{'color'});
3285 unless ($color) {
3286 $self->{ERRSTR} = $Imager::ERRSTR;
3287 return;
3288 }
3289 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3290 }
3291 if ($rc) {
3292 return $self;
3293 }
3294 else {
3295 $self->{ERRSTR} = $self->_error_as_msg();
aa833c97 3296 return;
3a9a4241 3297 }
3efb0915 3298 }
cc6483e0
TC
3299}
3300
591b5954 3301sub setpixel {
b3cdc973 3302 my ($self, %opts) = @_;
591b5954 3303
2a27eeff
TC
3304 $self->_valid_image("setpixel")
3305 or return;
3306
b3cdc973
TC
3307 my $color = $opts{color};
3308 unless (defined $color) {
3309 $color = $self->{fg};
3310 defined $color or $color = NC(255, 255, 255);
3311 }
3312
3313 unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
2a27eeff
TC
3314 unless ($color = _color($color, 'setpixel')) {
3315 $self->_set_error("setpixel: " . Imager->errstr);
3316 return;
3317 }
b3cdc973 3318 }
591b5954
TC
3319
3320 unless (exists $opts{'x'} && exists $opts{'y'}) {
2a27eeff
TC
3321 $self->_set_error('setpixel: missing x or y parameter');
3322 return;
591b5954
TC
3323 }
3324
3325 my $x = $opts{'x'};
3326 my $y = $opts{'y'};
2a27eeff
TC
3327 if (ref $x || ref $y) {
3328 $x = ref $x ? $x : [ $x ];
3329 $y = ref $y ? $y : [ $y ];
3330 unless (@$x) {
3331 $self->_set_error("setpixel: x is a reference to an empty array");
3332 return;
3333 }
3334 unless (@$y) {
3335 $self->_set_error("setpixel: y is a reference to an empty array");
837a4b43 3336 return;
591b5954 3337 }
2a27eeff
TC
3338
3339 # make both the same length, replicating the last element
3340 if (@$x < @$y) {
3341 $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3342 }
3343 elsif (@$y < @$x) {
3344 $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3345 }
3346
837a4b43 3347 my $set = 0;
591b5954 3348 if ($color->isa('Imager::Color')) {
2a27eeff 3349 for my $i (0..$#$x) {
837a4b43
TC
3350 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3351 or ++$set;
591b5954
TC
3352 }
3353 }
3354 else {
2a27eeff 3355 for my $i (0..$#$x) {
837a4b43
TC
3356 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3357 or ++$set;
591b5954
TC
3358 }
3359 }
2a27eeff 3360
837a4b43 3361 return $set;
591b5954
TC
3362 }
3363 else {
3364 if ($color->isa('Imager::Color')) {
837a4b43 3365 i_ppix($self->{IMG}, $x, $y, $color)
5daeb11a 3366 and return "0 but true";
591b5954
TC
3367 }
3368 else {
837a4b43 3369 i_ppixf($self->{IMG}, $x, $y, $color)
5daeb11a 3370 and return "0 but true";
591b5954 3371 }
591b5954 3372
5daeb11a
TC
3373 return 1;
3374 }
591b5954
TC
3375}
3376
3377sub getpixel {
3378 my $self = shift;
3379
a9fa203f 3380 my %opts = ( "type"=>'8bit', @_);
591b5954 3381
2a27eeff
TC
3382 $self->_valid_image("getpixel")
3383 or return;
3384
591b5954 3385 unless (exists $opts{'x'} && exists $opts{'y'}) {
2a27eeff
TC
3386 $self->_set_error('getpixel: missing x or y parameter');
3387 return;
591b5954
TC
3388 }
3389
3390 my $x = $opts{'x'};
3391 my $y = $opts{'y'};
2a27eeff
TC
3392 my $type = $opts{'type'};
3393 if (ref $x || ref $y) {
3394 $x = ref $x ? $x : [ $x ];
3395 $y = ref $y ? $y : [ $y ];
3396 unless (@$x) {
3397 $self->_set_error("getpixel: x is a reference to an empty array");
3398 return;
3399 }
3400 unless (@$y) {
3401 $self->_set_error("getpixel: y is a reference to an empty array");
3402 return;
3403 }
3404
3405 # make both the same length, replicating the last element
3406 if (@$x < @$y) {
3407 $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
591b5954 3408 }
2a27eeff
TC
3409 elsif (@$y < @$x) {
3410 $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3411 }
3412
591b5954 3413 my @result;
2a27eeff
TC
3414 if ($type eq '8bit') {
3415 for my $i (0..$#$x) {
591b5954
TC
3416 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3417 }
3418 }
2a27eeff
TC
3419 elsif ($type eq 'float' || $type eq 'double') {
3420 for my $i (0..$#$x) {
591b5954
TC
3421 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3422 }
3423 }
2a27eeff
TC
3424 else {
3425 $self->_set_error("getpixel: type must be '8bit' or 'float'");
3426 return;
3427 }
591b5954
TC
3428 return wantarray ? @result : \@result;
3429 }
3430 else {
2a27eeff 3431 if ($type eq '8bit') {
591b5954
TC
3432 return i_get_pixel($self->{IMG}, $x, $y);
3433 }
2a27eeff 3434 elsif ($type eq 'float' || $type eq 'double') {
591b5954
TC
3435 return i_gpixf($self->{IMG}, $x, $y);
3436 }
2a27eeff
TC
3437 else {
3438 $self->_set_error("getpixel: type must be '8bit' or 'float'");
3439 return;
3440 }
591b5954 3441 }
591b5954
TC
3442}
3443
ca4d914e
TC
3444sub getscanline {
3445 my $self = shift;
3446 my %opts = ( type => '8bit', x=>0, @_);
3447
1136f089
TC
3448 $self->_valid_image("getscanline")
3449 or return;
4cda4e76 3450
ca4d914e
TC
3451 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3452
3453 unless (defined $opts{'y'}) {
3454 $self->_set_error("missing y parameter");
3455 return;
3456 }
3457
3458 if ($opts{type} eq '8bit') {
3459 return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76 3460 $opts{'y'});
ca4d914e
TC
3461 }
3462 elsif ($opts{type} eq 'float') {
3463 return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76
TC
3464 $opts{'y'});
3465 }
3466 elsif ($opts{type} eq 'index') {
3467 unless (i_img_type($self->{IMG})) {
3468 $self->_set_error("type => index only valid on paletted images");
3469 return;
3470 }
3471 return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3472 $opts{'y'});
ca4d914e
TC
3473 }
3474 else {
3475 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3476 return;
3477 }
3478}
3479
3480sub setscanline {
3481 my $self = shift;
3482 my %opts = ( x=>0, @_);
3483
1136f089
TC
3484 $self->_valid_image("setscanline")
3485 or return;
4cda4e76 3486
ca4d914e
TC
3487 unless (defined $opts{'y'}) {
3488 $self->_set_error("missing y parameter");
3489 return;
3490 }
3491
3492 if (!$opts{type}) {
3493 if (ref $opts{pixels} && @{$opts{pixels}}) {
3494 # try to guess the type
3495 if ($opts{pixels}[0]->isa('Imager::Color')) {
3496 $opts{type} = '8bit';
3497 }
3498 elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3499 $opts{type} = 'float';
3500 }
3501 else {
3502 $self->_set_error("missing type parameter and could not guess from pixels");
3503 return;
3504 }
3505 }
3506 else {
3507 # default
3508 $opts{type} = '8bit';
3509 }
3510 }
3511
3512 if ($opts{type} eq '8bit') {
3513 if (ref $opts{pixels}) {
3514 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3515 }
3516 else {
3517 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3518 }
3519 }
3520 elsif ($opts{type} eq 'float') {
3521 if (ref $opts{pixels}) {
3522 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3523 }
3524 else {
3525 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3526 }
3527 }
4cda4e76
TC
3528 elsif ($opts{type} eq 'index') {
3529 if (ref $opts{pixels}) {
3530 return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3531 }
3532 else {
3533 return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3534 }
3535 }
ca4d914e
TC
3536 else {
3537 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3538 return;
3539 }
3540}
3541
3542sub getsamples {
3543 my $self = shift;
bd8052a6 3544 my %opts = ( type => '8bit', x=>0, offset => 0, @_);
ca4d914e 3545
1136f089
TC
3546 $self->_valid_image("getsamples")
3547 or return;
3548
ca4d914e
TC
3549 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3550
3551 unless (defined $opts{'y'}) {
3552 $self->_set_error("missing y parameter");
3553 return;
3554 }
3555
bd8052a6
TC
3556 if ($opts{target}) {
3557 my $target = $opts{target};
3558 my $offset = $opts{offset};
3559 if ($opts{type} eq '8bit') {
3560 my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
6a9807e8 3561 $opts{y}, $opts{channels})
bd8052a6 3562 or return;
b759736e 3563 @{$target}[$offset .. $offset + @samples - 1] = @samples;
bd8052a6
TC
3564 return scalar(@samples);
3565 }
3566 elsif ($opts{type} eq 'float') {
3567 my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
6a9807e8 3568 $opts{y}, $opts{channels});
b759736e 3569 @{$target}[$offset .. $offset + @samples - 1] = @samples;
bd8052a6
TC
3570 return scalar(@samples);
3571 }
3572 elsif ($opts{type} =~ /^(\d+)bit$/) {
3573 my $bits = $1;
3574
3575 my @data;
3576 my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3577 $opts{y}, $bits, $target,
6a9807e8 3578 $offset, $opts{channels});
bd8052a6
TC
3579 unless (defined $count) {
3580 $self->_set_error(Imager->_error_as_msg);
3581 return;
3582 }
3583
3584 return $count;
3585 }
3586 else {
3587 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3588 return;
3589 }
ca4d914e
TC
3590 }
3591 else {
bd8052a6
TC
3592 if ($opts{type} eq '8bit') {
3593 return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
6a9807e8 3594 $opts{y}, $opts{channels});
bd8052a6
TC
3595 }
3596 elsif ($opts{type} eq 'float') {
3597 return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
6a9807e8 3598 $opts{y}, $opts{channels});
bd8052a6
TC
3599 }
3600 elsif ($opts{type} =~ /^(\d+)bit$/) {
3601 my $bits = $1;
3602
3603 my @data;
3604 i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
6a9807e8 3605 $opts{y}, $bits, \@data, 0, $opts{channels})
bd8052a6
TC
3606 or return;
3607 return @data;
3608 }
3609 else {
3610 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3611 return;
3612 }
3613 }
3614}
3615
3616sub setsamples {
3617 my $self = shift;
bd8052a6 3618
1136f089
TC
3619 $self->_valid_image("setsamples")
3620 or return;
bd8052a6 3621
88ace6cd
TC
3622 my %opts = ( x => 0, offset => 0 );
3623 my $data_index;
3624 # avoid duplicating the data parameter, it may be a large scalar
3625 my $i = 0;
3626 while ($i < @_ -1) {
3627 if ($_[$i] eq 'data') {
3628 $data_index = $i+1;
3629 }
3630 else {
3631 $opts{$_[$i]} = $_[$i+1];
3632 }
3633
3634 $i += 2;
3635 }
3636
3637 unless(defined $data_index) {
f1d3d94a 3638 $self->_set_error('setsamples: data parameter missing');
ca4d914e
TC
3639 return;
3640 }
88ace6cd
TC
3641 unless (defined $_[$data_index]) {
3642 $self->_set_error('setsamples: data parameter not defined');
3643 return;
3644 }
bd8052a6 3645
f1d3d94a
TC
3646 my $type = $opts{type};
3647 defined $type or $type = '8bit';
3648
3649 my $width = defined $opts{width} ? $opts{width}
3650 : $self->getwidth() - $opts{x};
3651
3652 my $count;
3653 if ($type eq '8bit') {
3654 $count = i_psamp($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
88ace6cd 3655 $_[$data_index], $opts{offset}, $width);
f1d3d94a
TC
3656 }
3657 elsif ($type eq 'float') {
3658 $count = i_psampf($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
88ace6cd 3659 $_[$data_index], $opts{offset}, $width);
bd8052a6 3660 }
f1d3d94a
TC
3661 elsif ($type =~ /^([0-9]+)bit$/) {
3662 my $bits = $1;
bd8052a6 3663
88ace6cd 3664 unless (ref $_[$data_index]) {
f1d3d94a
TC
3665 $self->_set_error("setsamples: data must be an array ref for type not 8bit or float");
3666 return;
3667 }
3668
3669 $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
88ace6cd 3670 $opts{channels}, $_[$data_index], $opts{offset},
f1d3d94a
TC
3671 $width);
3672 }
3673 else {
3674 $self->_set_error('setsamples: type parameter invalid');
3675 return;
bd8052a6
TC
3676 }
3677
bd8052a6
TC
3678 unless (defined $count) {
3679 $self->_set_error(Imager->_error_as_msg);
3680 return;
3681 }
3682
3683 return $count;
ca4d914e
TC
3684}
3685
f5991c03
TC
3686# make an identity matrix of the given size
3687sub _identity {
3688 my ($size) = @_;
3689
3690 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3691 for my $c (0 .. ($size-1)) {
3692 $matrix->[$c][$c] = 1;
3693 }
3694 return $matrix;
3695}
3696
3697# general function to convert an image
3698sub convert {
3699 my ($self, %opts) = @_;
3700 my $matrix;
3701
1136f089
TC
3702 $self->_valid_image("convert")
3703 or return;
3704
34b3f7e6
TC
3705 unless (defined wantarray) {
3706 my @caller = caller;
3707 warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3708 return;
3709 }
3710
f5991c03
TC
3711 # the user can either specify a matrix or preset
3712 # the matrix overrides the preset
3713 if (!exists($opts{matrix})) {
3714 unless (exists($opts{preset})) {
3715 $self->{ERRSTR} = "convert() needs a matrix or preset";
3716 return;
3717 }
3718 else {
3719 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3720 # convert to greyscale, keeping the alpha channel if any
3721 if ($self->getchannels == 3) {
3722 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3723 }
3724 elsif ($self->getchannels == 4) {
3725 # preserve the alpha channel
3726 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3727 [ 0, 0, 0, 1 ] ];
3728 }
3729 else {
3730 # an identity
3731 $matrix = _identity($self->getchannels);
3732 }
3733 }
3734 elsif ($opts{preset} eq 'noalpha') {
3735 # strip the alpha channel
3736 if ($self->getchannels == 2 or $self->getchannels == 4) {
3737 $matrix = _identity($self->getchannels);
3738 pop(@$matrix); # lose the alpha entry
3739 }
3740 else {
3741 $matrix = _identity($self->getchannels);
3742 }
3743 }
3744 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3745 # extract channel 0
3746 $matrix = [ [ 1 ] ];
3747 }
3748 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3749 $matrix = [ [ 0, 1 ] ];
3750 }
3751 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3752 $matrix = [ [ 0, 0, 1 ] ];
3753 }
3754 elsif ($opts{preset} eq 'alpha') {
3755 if ($self->getchannels == 2 or $self->getchannels == 4) {
3756 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3757 }
3758 else {
3759 # the alpha is just 1 <shrug>
3760 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3761 }
3762 }
3763 elsif ($opts{preset} eq 'rgb') {
3764 if ($self->getchannels == 1) {
3765 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3766 }
3767 elsif ($self->getchannels == 2) {
3768 # preserve the alpha channel
3769 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3770 }
3771 else {
3772 $matrix = _identity($self->getchannels);
3773 }
3774 }
3775 elsif ($opts{preset} eq 'addalpha') {
3776 if ($self->getchannels == 1) {
3777 $matrix = _identity(2);
3778 }
3779 elsif ($self->getchannels == 3) {
3780 $matrix = _identity(4);
3781 }
3782 else {
3783 $matrix = _identity($self->getchannels);
3784 }
3785 }
3786 else {
3787 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3788 return undef;
3789 }
3790 }
3791 }
3792 else {
3793 $matrix = $opts{matrix};
3794 }
3795
d5477d3d
TC
3796 my $new = Imager->new;
3797 $new->{IMG} = i_convert($self->{IMG}, $matrix);
3798 unless ($new->{IMG}) {
f5991c03 3799 # most likely a bad matrix
26eb06dd 3800 i_push_error(0, "convert");
f5991c03
TC
3801 $self->{ERRSTR} = _error_as_msg();
3802 return undef;
3803 }
3804 return $new;
3805}
40eba1ea 3806
b47464c1
TC
3807# combine channels from multiple input images, a class method
3808sub combine {
3809 my ($class, %opts) = @_;
3810
3811 my $src = delete $opts{src};
3812 unless ($src) {
3813 $class->_set_error("src parameter missing");
3814 return;
3815 }
3816 my @imgs;
3817 my $index = 0;
3818 for my $img (@$src) {
3819 unless (eval { $img->isa("Imager") }) {
3820 $class->_set_error("src must contain image objects");
3821 return;
3822 }
1136f089
TC
3823 unless ($img->_valid_image("combine")) {
3824 $Imager::ERRSTR = $img->{ERRSTR} . " (src->[$index])";
b47464c1
TC
3825 return;
3826 }
3827 push @imgs, $img->{IMG};
3828 }
3829 my $result;
3830 if (my $channels = delete $opts{channels}) {
3831 $result = i_combine(\@imgs, $channels);
3832 }
3833 else {
3834 $result = i_combine(\@imgs);
3835 }
3836 unless ($result) {
3837 $class->_set_error($class->_error_as_msg);
3838 return;
3839 }
3840
3841 my $img = $class->new;
3842 $img->{IMG} = $result;
3843
3844 return $img;
3845}
3846
40eba1ea 3847
40eba1ea 3848# general function to map an image through lookup tables
9495ee93 3849
40eba1ea
AMH
3850sub map {
3851 my ($self, %opts) = @_;
9495ee93 3852 my @chlist = qw( red green blue alpha );
40eba1ea 3853
1136f089
TC
3854 $self->_valid_image("map")
3855 or return;
3856
40eba1ea
AMH
3857 if (!exists($opts{'maps'})) {
3858 # make maps from channel maps
3859 my $chnum;
3860 for $chnum (0..$#chlist) {
9495ee93
AMH
3861 if (exists $opts{$chlist[$chnum]}) {
3862 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3863 } elsif (exists $opts{'all'}) {
3864 $opts{'maps'}[$chnum] = $opts{'all'};
3865 }
40eba1ea
AMH
3866 }
3867 }
3868 if ($opts{'maps'} and $self->{IMG}) {
3869 i_map($self->{IMG}, $opts{'maps'} );
3870 }
3871 return $self;
3872}
3873
dff75dee
TC
3874sub difference {
3875 my ($self, %opts) = @_;
3876
1136f089
TC
3877 $self->_valid_image("difference")
3878 or return;
3879
dff75dee
TC
3880 defined $opts{mindist} or $opts{mindist} = 0;
3881
3882 defined $opts{other}
3883 or return $self->_set_error("No 'other' parameter supplied");
1136f089
TC
3884 unless ($opts{other}->_valid_image("difference")) {
3885 $self->_set_error($opts{other}->errstr . " (other image)");
3886 return;
3887 }
dff75dee
TC
3888
3889 my $result = Imager->new;
3890 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3891 $opts{mindist})
3892 or return $self->_set_error($self->_error_as_msg());
3893
3894 return $result;
3895}
3896
02d1d628
AMH
3897# destructive border - image is shrunk by one pixel all around
3898
3899sub border {
3900 my ($self,%opts)=@_;
3901 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3902 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3903}
3904
3905
3906# Get the width of an image
3907
3908sub getwidth {
3909 my $self = shift;
3b000586 3910
1136f089
TC
3911 $self->_valid_image("getwidth")
3912 or return;
3913
3914 return i_img_get_width($self->{IMG});
02d1d628
AMH
3915}
3916
3917# Get the height of an image
3918
3919sub getheight {
3920 my $self = shift;
3b000586 3921
1136f089
TC
3922 $self->_valid_image("getheight")
3923 or return;
3924
3925 return i_img_get_height($self->{IMG});
02d1d628
AMH
3926}
3927
3928# Get number of channels in an image
3929
3930sub getchannels {
3931 my $self = shift;
1136f089
TC
3932
3933 $self->_valid_image("getchannels")
3934 or return;
3935
02d1d628
AMH
3936 return i_img_getchannels($self->{IMG});
3937}
3938
35db02fc
TC
3939my @model_names = qw(unknown gray graya rgb rgba);
3940
3941sub colormodel {
3942 my ($self, %opts) = @_;
3943
3944 $self->_valid_image("colormodel")
3945 or return;
3946
3947 my $model = i_img_color_model($self->{IMG});
3948
3949 return $opts{numeric} ? $model : $model_names[$model];
3950}
3951
3952sub colorchannels {
3953 my ($self) = @_;
3954
3955 $self->_valid_image("colorchannels")
3956 or return;
3957
3958 return i_img_color_channels($self->{IMG});
3959}
3960
3961sub alphachannel {
3962 my ($self) = @_;
3963
3964 $self->_valid_image("alphachannel")
3965 or return;
3966
3967 return scalar(i_img_alpha_channel($self->{IMG}));
3968}
3969
02d1d628
AMH
3970# Get channel mask
3971
3972sub getmask {
3973 my $self = shift;
1136f089
TC
3974
3975 $self->_valid_image("getmask")
3976 or return;
3977
02d1d628
AMH
3978 return i_img_getmask($self->{IMG});
3979}
3980
3981# Set channel mask
3982
3983sub setmask {
3984 my $self = shift;
3985 my %opts = @_;
1136f089
TC
3986
3987 $self->_valid_image("setmask")
3988 or return;
3989
35f40526
TC
3990 unless (defined $opts{mask}) {
3991 $self->_set_error("mask parameter required");
3992 return;
3993 }
1136f089 3994
02d1d628 3995 i_img_setmask( $self->{IMG} , $opts{mask} );
35f40526
TC
3996
3997 1;
02d1d628
AMH
3998}