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