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