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