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