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