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