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