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