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