projects / imager.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
- writing a 2 or 4 channel image to a JPEG will now write that image as
[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
6e4af7d4
TC		 1596# options that should be converted to colors
1597my %color_opts = map { $_ => 1 } qw/i_background/;
1598
97c4effc
TC		 1599sub _set_opts {
1600 my ($self, $opts, $prefix, @imgs) = @_;
1601
1602 for my $opt (keys %$opts) {
1603 my $tagname = $opt;
1604 if ($obsolete_opts{$opt}) {
1605 my $new = $obsolete_opts{$opt};
1606 my $msg = "Obsolete option $opt ";
1607 if (ref $new) {
1608 $new->($opts, $opt, \$msg, @imgs);
1609 }
1610 else {
1611 $msg .= "replaced with the $new tag ";
1612 $tagname = $new;
1613 }
1614 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1615 warn $msg if $warn_obsolete && $^W;
1616 }
1617 next unless $tagname =~ /^\Q$prefix/;
1618 my $value = $opts->{$opt};
6e4af7d4
TC		 1619 if ($color_opts{$opt}) {
1620 $value = _color($value);
1621 unless ($value) {
1622 $self->_set_error($Imager::ERRSTR);
1623 return;
1624 }
1625 }
97c4effc
TC		 1626 if (ref $value) {
1627 if (UNIVERSAL::isa($value, "Imager::Color")) {
1628 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1629 for my $img (@imgs) {
1630 $img->settag(name=>$tagname, value=>$tag);
1631 }
1632 }
1633 elsif (ref($value) eq 'ARRAY') {
1634 for my $i (0..$#$value) {
1635 my $val = $value->[$i];
1636 if (ref $val) {
1637 if (UNIVERSAL::isa($val, "Imager::Color")) {
1638 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1639 $i < @imgs and
1640 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1641 }
1642 else {
1643 $self->_set_error("Unknown reference type " . ref($value) .
1644 " supplied in array for $opt");
1645 return;
1646 }
1647 }
1648 else {
1649 $i < @imgs
1650 and $imgs[$i]->settag(name=>$tagname, value=>$val);
1651 }
1652 }
1653 }
1654 else {
1655 $self->_set_error("Unknown reference type " . ref($value) .
1656 " supplied for $opt");
1657 return;
1658 }
1659 }
1660 else {
1661 # set it as a tag for every image
1662 for my $img (@imgs) {
1663 $img->settag(name=>$tagname, value=>$value);
1664 }
1665 }
1666 }
1667
1668 return 1;
1669}
1670
02d1d628 1671# Write an image to file
02d1d628
AMH		 1672sub write {
1673 my $self = shift;
2fe0b227
AMH		 1674 my %input=(jpegquality=>75,
1675 gifquant=>'mc',
1676 lmdither=>6.0,
febba01f
AMH		 1677 lmfixed=>[],
1678 idstring=>"",
1679 compress=>1,
1680 wierdpack=>0,
4c2d6970 1681 fax_fine=>1, @_);
10461f9a 1682 my $rc;
02d1d628 1683
97c4effc
TC		 1684 $self->_set_opts(\%input, "i_", $self)
1685 or return undef;
1686
02d1d628
AMH		 1687 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1688
9d540150
TC		 1689 if (!$input{'type'} and $input{file}) {
1690 $input{'type'}=$FORMATGUESS->($input{file});
1691 }
1692 if (!$input{'type'}) {
1693 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1694 return undef;
1695 }
02d1d628 1696
2b405c9e 1697 _writer_autoload($input{type});
02d1d628 1698
2b405c9e
TC		 1699 my ($IO, $fh);
1700 if ($writers{$input{type}} && $writers{$input{type}}{single}) {
1701 ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
2fe0b227 1702 or return undef;
febba01f 1703
2b405c9e 1704 $writers{$input{type}}{single}->($self, $IO, %input)
2fe0b227 1705 or return undef;
2b405c9e
TC		 1706 }
1707 else {
1708 if (!$formats{$input{'type'}}) {
f245645a
TC		 1709 my $write_types = join ', ', sort Imager->write_types();
1710 $self->_set_error("format '$input{'type'}' not supported - formats $write_types available for writing");
2fe0b227 1711 return undef;
930c67c8 1712 }
2b405c9e
TC		 1713
1714 ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
2fe0b227 1715 or return undef;
2b405c9e
TC		 1716
1717 if ($input{'type'} eq 'tiff') {
1718 $self->_set_opts(\%input, "tiff_", $self)
1719 or return undef;
1720 $self->_set_opts(\%input, "exif_", $self)
1721 or return undef;
1722
1723 if (defined $input{class} && $input{class} eq 'fax') {
1724 if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1725 $self->{ERRSTR} = $self->_error_as_msg();
1726 return undef;
1727 }
1728 } else {
1729 if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1730 $self->{ERRSTR} = $self->_error_as_msg();
1731 return undef;
1732 }
1733 }
1734 } elsif ( $input{'type'} eq 'pnm' ) {
1735 $self->_set_opts(\%input, "pnm_", $self)
1736 or return undef;
1737 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1738 $self->{ERRSTR} = $self->_error_as_msg();
1739 return undef;
1740 }
1741 $self->{DEBUG} && print "writing a pnm file\n";
1742 } elsif ( $input{'type'} eq 'raw' ) {
1743 $self->_set_opts(\%input, "raw_", $self)
1744 or return undef;
1745 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1746 $self->{ERRSTR} = $self->_error_as_msg();
1747 return undef;
1748 }
1749 $self->{DEBUG} && print "writing a raw file\n";
1750 } elsif ( $input{'type'} eq 'png' ) {
1751 $self->_set_opts(\%input, "png_", $self)
1752 or return undef;
1753 if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1754 $self->{ERRSTR}='unable to write png image';
1755 return undef;
1756 }
1757 $self->{DEBUG} && print "writing a png file\n";
1758 } elsif ( $input{'type'} eq 'jpeg' ) {
1759 $self->_set_opts(\%input, "jpeg_", $self)
1760 or return undef;
1761 $self->_set_opts(\%input, "exif_", $self)
1762 or return undef;
1763 if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1764 $self->{ERRSTR} = $self->_error_as_msg();
1765 return undef;
1766 }
1767 $self->{DEBUG} && print "writing a jpeg file\n";
1768 } elsif ( $input{'type'} eq 'bmp' ) {
1769 $self->_set_opts(\%input, "bmp_", $self)
1770 or return undef;
1771 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
ae12796a 1772 $self->{ERRSTR} = $self->_error_as_msg;
2b405c9e
TC		 1773 return undef;
1774 }
1775 $self->{DEBUG} && print "writing a bmp file\n";
1776 } elsif ( $input{'type'} eq 'tga' ) {
1777 $self->_set_opts(\%input, "tga_", $self)
1778 or return undef;
1779
1780 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1781 $self->{ERRSTR}=$self->_error_as_msg();
1782 return undef;
1783 }
1784 $self->{DEBUG} && print "writing a tga file\n";
1785 } elsif ( $input{'type'} eq 'gif' ) {
1786 $self->_set_opts(\%input, "gif_", $self)
1787 or return undef;
1788 # compatibility with the old interfaces
1789 if ($input{gifquant} eq 'lm') {
1790 $input{make_colors} = 'addi';
1791 $input{translate} = 'perturb';
1792 $input{perturb} = $input{lmdither};
1793 } elsif ($input{gifquant} eq 'gen') {
1794 # just pass options through
1795 } else {
1796 $input{make_colors} = 'webmap'; # ignored
1797 $input{translate} = 'giflib';
1798 }
1799 if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1800 $self->{ERRSTR} = $self->_error_as_msg;
1801 return;
1802 }
1501d9b3 1803 }
02d1d628 1804 }
10461f9a 1805
2fe0b227
AMH		 1806 if (exists $input{'data'}) {
1807 my $data = io_slurp($IO);
1808 if (!$data) {
1809 $self->{ERRSTR}='Could not slurp from buffer';
1810 return undef;
1811 }
1812 ${$input{data}} = $data;
1813 }
02d1d628
AMH		 1814 return $self;
1815}
1816
1817sub write_multi {
1818 my ($class, $opts, @images) = @_;
1819
2b405c9e
TC		 1820 my $type = $opts->{type};
1821
1822 if (!$type && $opts->{'file'}) {
1823 $type = $FORMATGUESS->($opts->{'file'});
10461f9a 1824 }
2b405c9e 1825 unless ($type) {
10461f9a
TC		 1826 $class->_set_error('type parameter missing and not possible to guess from extension');
1827 return;
1828 }
1829 # translate to ImgRaw
1830 if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1831 $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1832 return 0;
1833 }
97c4effc
TC		 1834 $class->_set_opts($opts, "i_", @images)
1835 or return;
10461f9a 1836 my @work = map $_->{IMG}, @images;
2b405c9e
TC		 1837
1838 _writer_autoload($type);
1839
1840 my ($IO, $file);
1841 if ($writers{$type} && $writers{$type}{multiple}) {
1842 ($IO, $file) = $class->_get_writer_io($opts, $type)
1843 or return undef;
1844
1845 $writers{$type}{multiple}->($class, $IO, $opts, @images)
1846 or return undef;
1847 }
1848 else {
1849 if (!$formats{$type}) {
f245645a
TC		 1850 my $write_types = join ', ', sort Imager->write_types();
1851 $class->_set_error("format '$type' not supported - formats $write_types available for writing");
2b405c9e
TC		 1852 return undef;
1853 }
1854
1855 ($IO, $file) = $class->_get_writer_io($opts, $type)
1856 or return undef;
1857
1858 if ($type eq 'gif') {
1859 $class->_set_opts($opts, "gif_", @images)
1860 or return;
1861 my $gif_delays = $opts->{gif_delays};
1862 local $opts->{gif_delays} = $gif_delays;
1863 if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1864 # assume the caller wants the same delay for each frame
1865 $opts->{gif_delays} = [ ($gif_delays) x @images ];
1866 }
1867 unless (i_writegif_wiol($IO, $opts, @work)) {
1868 $class->_set_error($class->_error_as_msg());
1869 return undef;
1870 }
1871 }
1872 elsif ($type eq 'tiff') {
1873 $class->_set_opts($opts, "tiff_", @images)
1874 or return;
1875 $class->_set_opts($opts, "exif_", @images)
1876 or return;
1877 my $res;
1878 $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1879 if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1880 $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1881 }
1882 else {
1883 $res = i_writetiff_multi_wiol($IO, @work);
1884 }
1885 unless ($res) {
1886 $class->_set_error($class->_error_as_msg());
1887 return undef;
1888 }
02d1d628
AMH		 1889 }
1890 else {
e7ff1cf7
TC		 1891 if (@images == 1) {
1892 unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1893 return 1;
1894 }
1895 }
1896 else {
1897 $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1898 return 0;
1899 }
02d1d628
AMH		 1900 }
1901 }
2b405c9e
TC		 1902
1903 if (exists $opts->{'data'}) {
1904 my $data = io_slurp($IO);
1905 if (!$data) {
1906 Imager->_set_error('Could not slurp from buffer');
1907 return undef;
1908 }
1909 ${$opts->{data}} = $data;
02d1d628 1910 }
2b405c9e 1911 return 1;
02d1d628
AMH		 1912}
1913
faa9b3e7
TC		 1914# read multiple images from a file
1915sub read_multi {
1916 my ($class, %opts) = @_;
1917
53a6bbd4
TC		 1918 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1919 or return;
1920
1921 my $type = $opts{'type'};
1922 unless ($type) {
1923 $type = i_test_format_probe($IO, -1);
1924 }
1925
1926 if ($opts{file} && !$type) {
faa9b3e7 1927 # guess the type
53a6bbd4 1928 $type = $FORMATGUESS->($opts{file});
faa9b3e7 1929 }
53a6bbd4
TC		 1930
1931 unless ($type) {
faa9b3e7
TC		 1932 $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1933 return;
1934 }
faa9b3e7 1935
53a6bbd4
TC		 1936 _reader_autoload($type);
1937
1938 if ($readers{$type} && $readers{$type}{multiple}) {
1939 return $readers{$type}{multiple}->($IO, %opts);
1940 }
1941
1942 if ($type eq 'gif') {
faa9b3e7 1943 my @imgs;
10461f9a
TC		 1944 @imgs = i_readgif_multi_wiol($IO);
1945 if (@imgs) {
1946 return map {
1947 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1948 } @imgs;
faa9b3e7
TC		 1949 }
1950 else {
10461f9a
TC		 1951 $ERRSTR = _error_as_msg();
1952 return;
faa9b3e7 1953 }
10461f9a 1954 }
53a6bbd4 1955 elsif ($type eq 'tiff') {
10461f9a 1956 my @imgs = i_readtiff_multi_wiol($IO, -1);
faa9b3e7
TC		 1957 if (@imgs) {
1958 return map {
1959 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1960 } @imgs;
1961 }
1962 else {
1963 $ERRSTR = _error_as_msg();
1964 return;
1965 }
1966 }
e7ff1cf7
TC		 1967 else {
1968 my $img = Imager->new;
1969 if ($img->read(%opts, io => $IO, type => $type)) {
1970 return ( $img );
1971 }
f245645a 1972 Imager->_set_error($img->errstr);
e7ff1cf7 1973 }
faa9b3e7 1974
faa9b3e7
TC		 1975 return;
1976}
1977
02d1d628
AMH		 1978# Destroy an Imager object
1979
1980sub DESTROY {
1981 my $self=shift;
1982 # delete $instances{$self};
1983 if (defined($self->{IMG})) {
faa9b3e7
TC		 1984 # the following is now handled by the XS DESTROY method for
1985 # Imager::ImgRaw object
1986 # Re-enabling this will break virtual images
1987 # tested for in t/t020masked.t
1988 # i_img_destroy($self->{IMG});
02d1d628
AMH		 1989 undef($self->{IMG});
1990 } else {
1991# print "Destroy Called on an empty image!\n"; # why did I put this here??
1992 }
1993}
1994
1995# Perform an inplace filter of an image
1996# that is the image will be overwritten with the data
1997
1998sub filter {
1999 my $self=shift;
2000 my %input=@_;
2001 my %hsh;
2002 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2003
9d540150 2004 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
02d1d628 2005
9d540150 2006 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
02d1d628
AMH		 2007 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2008 }
2009
9d540150
TC		 2010 if ($filters{$input{'type'}}{names}) {
2011 my $names = $filters{$input{'type'}}{names};
6607600c
TC		 2012 for my $name (keys %$names) {
2013 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2014 $input{$name} = $names->{$name}{$input{$name}};
2015 }
2016 }
2017 }
9d540150 2018 if (defined($filters{$input{'type'}}{defaults})) {
7327d4b0
TC		 2019 %hsh=( image => $self->{IMG},
2020 imager => $self,
2021 %{$filters{$input{'type'}}{defaults}},
2022 %input );
02d1d628 2023 } else {
7327d4b0
TC		 2024 %hsh=( image => $self->{IMG},
2025 imager => $self,
2026 %input );
02d1d628
AMH		 2027 }
2028
9d540150 2029 my @cs=@{$filters{$input{'type'}}{callseq}};
02d1d628
AMH		 2030
2031 for(@cs) {
2032 if (!defined($hsh{$_})) {
9d540150 2033 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
02d1d628
AMH		 2034 }
2035 }
2036
109bec2d
TC		 2037 eval {
2038 local $SIG{__DIE__}; # we don't want this processed by confess, etc
2039 &{$filters{$input{'type'}}{callsub}}(%hsh);
2040 };
2041 if ($@) {
2042 chomp($self->{ERRSTR} = $@);
2043 return;
2044 }
02d1d628
AMH		 2045
2046 my @b=keys %hsh;
2047
2048 $self->{DEBUG} && print "callseq is: @cs\n";
2049 $self->{DEBUG} && print "matching callseq is: @b\n";
2050
2051 return $self;
2052}
2053
92bda632
TC		 2054sub register_filter {
2055 my $class = shift;
2056 my %hsh = ( defaults => {}, @_ );
2057
2058 defined $hsh{type}
2059 or die "register_filter() with no type\n";
2060 defined $hsh{callsub}
2061 or die "register_filter() with no callsub\n";
2062 defined $hsh{callseq}
2063 or die "register_filter() with no callseq\n";
2064
2065 exists $filters{$hsh{type}}
2066 and return;
2067
2068 $filters{$hsh{type}} = \%hsh;
2069
2070 return 1;
2071}
2072
df9aaafb
TC		 2073sub scale_calculate {
2074 my $self = shift;
02d1d628 2075
df9aaafb 2076 my %opts = ('type'=>'max', @_);
4f579313 2077
df9aaafb
TC		 2078 my ($x_scale, $y_scale);
2079 my $width = $opts{width};
2080 my $height = $opts{height};
2081 if (ref $self) {
2082 defined $width or $width = $self->getwidth;
2083 defined $height or $height = $self->getheight;
ace46df2 2084 }
df9aaafb
TC		 2085 else {
2086 unless (defined $width && defined $height) {
2087 $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2088 return;
2089 }
5168ca3a 2090 }
02d1d628 2091
658f724e
TC		 2092 if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2093 $x_scale = $opts{'xscalefactor'};
2094 $y_scale = $opts{'yscalefactor'};
2095 }
2096 elsif ($opts{'xscalefactor'}) {
2097 $x_scale = $opts{'xscalefactor'};
2098 $y_scale = $opts{'scalefactor'} || $x_scale;
2099 }
2100 elsif ($opts{'yscalefactor'}) {
2101 $y_scale = $opts{'yscalefactor'};
2102 $x_scale = $opts{'scalefactor'} || $y_scale;
2103 }
2104 else {
2105 $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2106 }
2107
5168ca3a 2108 # work out the scaling
9d540150 2109 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
df9aaafb
TC		 2110 my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2111 $opts{ypixels} / $height );
5168ca3a 2112 if ($opts{'type'} eq 'min') {
658f724e 2113 $x_scale = $y_scale = _min($xpix,$ypix);
5168ca3a
TC		 2114 }
2115 elsif ($opts{'type'} eq 'max') {
658f724e
TC		 2116 $x_scale = $y_scale = _max($xpix,$ypix);
2117 }
2118 elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2119 $x_scale = $xpix;
2120 $y_scale = $ypix;
5168ca3a
TC		 2121 }
2122 else {
2123 $self->_set_error('invalid value for type parameter');
df9aaafb 2124 return;
5168ca3a
TC		 2125 }
2126 } elsif ($opts{xpixels}) {
df9aaafb 2127 $x_scale = $y_scale = $opts{xpixels} / $width;
5168ca3a
TC		 2128 }
2129 elsif ($opts{ypixels}) {
df9aaafb 2130 $x_scale = $y_scale = $opts{ypixels}/$height;
5168ca3a 2131 }
41c7d053
TC		 2132 elsif ($opts{constrain} && ref $opts{constrain}
2133 && $opts{constrain}->can('constrain')) {
2134 # we've been passed an Image::Math::Constrain object or something
2135 # that looks like one
658f724e 2136 my $scalefactor;
4f579313 2137 (undef, undef, $scalefactor)
41c7d053 2138 = $opts{constrain}->constrain($self->getwidth, $self->getheight);
4f579313 2139 unless ($scalefactor) {
41c7d053 2140 $self->_set_error('constrain method failed on constrain parameter');
df9aaafb 2141 return;
41c7d053 2142 }
658f724e 2143 $x_scale = $y_scale = $scalefactor;
41c7d053 2144 }
02d1d628 2145
df9aaafb
TC		 2146 my $new_width = int($x_scale * $width + 0.5);
2147 $new_width > 0 or $new_width = 1;
2148 my $new_height = int($y_scale * $height + 0.5);
2149 $new_height > 0 or $new_height = 1;
2150
2151 return ($x_scale, $y_scale, $new_width, $new_height);
2152
2153}
2154
2155# Scale an image to requested size and return the scaled version
2156
2157sub scale {
2158 my $self=shift;
2159 my %opts = (qtype=>'normal' ,@_);
2160 my $img = Imager->new();
2161 my $tmp = Imager->new();
2162
2163 unless (defined wantarray) {
2164 my @caller = caller;
2165 warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2166 return;
2167 }
2168
2169 unless ($self->{IMG}) {
2170 $self->_set_error('empty input image');
2171 return undef;
2172 }
2173
2174 my ($x_scale, $y_scale, $new_width, $new_height) =
2175 $self->scale_calculate(%opts)
2176 or return;
2177
02d1d628 2178 if ($opts{qtype} eq 'normal') {
658f724e 2179 $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
5168ca3a 2180 if ( !defined($tmp->{IMG}) ) {
4f579313 2181 $self->{ERRSTR} = 'unable to scale image';
5168ca3a
TC		 2182 return undef;
2183 }
658f724e 2184 $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
5168ca3a
TC		 2185 if ( !defined($img->{IMG}) ) {
2186 $self->{ERRSTR}='unable to scale image';
2187 return undef;
2188 }
2189
02d1d628
AMH		 2190 return $img;
2191 }
5168ca3a 2192 elsif ($opts{'qtype'} eq 'preview') {
658f724e 2193 $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
5168ca3a
TC		 2194 if ( !defined($img->{IMG}) ) {
2195 $self->{ERRSTR}='unable to scale image';
2196 return undef;
2197 }
02d1d628
AMH		 2198 return $img;
2199 }
658f724e 2200 elsif ($opts{'qtype'} eq 'mixing') {
658f724e
TC		 2201 $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2202 unless ($img->{IMG}) {
2203 $self->_set_error(Imager->_error_as_meg);
2204 return;
2205 }
2206 return $img;
2207 }
5168ca3a
TC		 2208 else {
2209 $self->_set_error('invalid value for qtype parameter');
2210 return undef;
2211 }
02d1d628
AMH		 2212}
2213
2214# Scales only along the X axis
2215
2216sub scaleX {
15327bf5
TC		 2217 my $self = shift;
2218 my %opts = ( scalefactor=>0.5, @_ );
02d1d628 2219
34b3f7e6
TC		 2220 unless (defined wantarray) {
2221 my @caller = caller;
2222 warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2223 return;
2224 }
2225
15327bf5
TC		 2226 unless ($self->{IMG}) {
2227 $self->{ERRSTR} = 'empty input image';
2228 return undef;
2229 }
02d1d628
AMH		 2230
2231 my $img = Imager->new();
2232
15327bf5 2233 my $scalefactor = $opts{scalefactor};
02d1d628 2234
15327bf5
TC		 2235 if ($opts{pixels}) {
2236 $scalefactor = $opts{pixels} / $self->getwidth();
2237 }
2238
2239 unless ($self->{IMG}) {
2240 $self->{ERRSTR}='empty input image';
2241 return undef;
2242 }
2243
2244 $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2245
2246 if ( !defined($img->{IMG}) ) {
2247 $self->{ERRSTR} = 'unable to scale image';
2248 return undef;
2249 }
02d1d628 2250
02d1d628
AMH		 2251 return $img;
2252}
2253
2254# Scales only along the Y axis
2255
2256sub scaleY {
15327bf5
TC		 2257 my $self = shift;
2258 my %opts = ( scalefactor => 0.5, @_ );
02d1d628 2259
34b3f7e6
TC		 2260 unless (defined wantarray) {
2261 my @caller = caller;
2262 warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2263 return;
2264 }
2265
02d1d628
AMH		 2266 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2267
2268 my $img = Imager->new();
2269
15327bf5 2270 my $scalefactor = $opts{scalefactor};
02d1d628 2271
15327bf5
TC		 2272 if ($opts{pixels}) {
2273 $scalefactor = $opts{pixels} / $self->getheight();
2274 }
2275
2276 unless ($self->{IMG}) {
2277 $self->{ERRSTR} = 'empty input image';
2278 return undef;
2279 }
2280 $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2281
2282 if ( !defined($img->{IMG}) ) {
2283 $self->{ERRSTR} = 'unable to scale image';
2284 return undef;
2285 }
02d1d628 2286
02d1d628
AMH		 2287 return $img;
2288}
2289
02d1d628
AMH		 2290# Transform returns a spatial transformation of the input image
2291# this moves pixels to a new location in the returned image.
2292# NOTE - should make a utility function to check transforms for
2293# stack overruns
2294
2295sub transform {
2296 my $self=shift;
2297 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2298 my %opts=@_;
2299 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2300
2301# print Dumper(\%opts);
2302# xopcopdes
2303
2304 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2305 if (!$I2P) {
2306 eval ("use Affix::Infix2Postfix;");
2307 print $@;
2308 if ( $@ ) {
2309 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2310 return undef;
2311 }
2312 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2313 {op=>'-',trans=>'Sub'},
2314 {op=>'*',trans=>'Mult'},
2315 {op=>'/',trans=>'Div'},
9d540150 2316 {op=>'-','type'=>'unary',trans=>'u-'},
02d1d628 2317 {op=>'**'},
9d540150 2318 {op=>'func','type'=>'unary'}],
02d1d628
AMH		 2319 'grouping'=>[qw( \( \) )],
2320 'func'=>[qw( sin cos )],
2321 'vars'=>[qw( x y )]
2322 );
2323 }
2324
2325 @xt=$I2P->translate($opts{'xexpr'});
2326 @yt=$I2P->translate($opts{'yexpr'});
2327
2328 $numre=$I2P->{'numre'};
2329 @pt=(0,0);
2330
2331 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2332 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2333 @{$opts{'parm'}}=@pt;
2334 }
2335
2336# print Dumper(\%opts);
2337
2338 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2339 $self->{ERRSTR}='transform: no xopcodes given.';
2340 return undef;
2341 }
2342
2343 @op=@{$opts{'xopcodes'}};
2344 for $iop (@op) {
2345 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2346 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2347 return undef;
2348 }
2349 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2350 }
2351
2352
2353# yopcopdes
2354
2355 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2356 $self->{ERRSTR}='transform: no yopcodes given.';
2357 return undef;
2358 }
2359
2360 @op=@{$opts{'yopcodes'}};
2361 for $iop (@op) {
2362 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2363 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2364 return undef;
2365 }
2366 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2367 }
2368
2369#parameters
2370
2371 if ( !exists $opts{'parm'}) {
2372 $self->{ERRSTR}='transform: no parameter arg given.';
2373 return undef;
2374 }
2375
2376# print Dumper(\@ropx);
2377# print Dumper(\@ropy);
2378# print Dumper(\@ropy);
2379
2380 my $img = Imager->new();
2381 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2382 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2383 return $img;
2384}
2385
2386
bf94b653
TC		 2387sub transform2 {
2388 my ($opts, @imgs) = @_;
2389
2390 require "Imager/Expr.pm";
2391
2392 $opts->{variables} = [ qw(x y) ];
2393 my ($width, $height) = @{$opts}{qw(width height)};
2394 if (@imgs) {
2395 $width ||= $imgs[0]->getwidth();
2396 $height ||= $imgs[0]->getheight();
2397 my $img_num = 1;
2398 for my $img (@imgs) {
2399 $opts->{constants}{"w$img_num"} = $img->getwidth();
2400 $opts->{constants}{"h$img_num"} = $img->getheight();
2401 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2402 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2403 ++$img_num;
02d1d628 2404 }
02d1d628 2405 }
bf94b653
TC		 2406 if ($width) {
2407 $opts->{constants}{w} = $width;
2408 $opts->{constants}{cx} = $width/2;
2409 }
2410 else {
2411 $Imager::ERRSTR = "No width supplied";
2412 return;
2413 }
2414 if ($height) {
2415 $opts->{constants}{h} = $height;
2416 $opts->{constants}{cy} = $height/2;
2417 }
2418 else {
2419 $Imager::ERRSTR = "No height supplied";
2420 return;
2421 }
2422 my $code = Imager::Expr->new($opts);
2423 if (!$code) {
2424 $Imager::ERRSTR = Imager::Expr::error();
2425 return;
2426 }
e5744e01
TC		 2427 my $channels = $opts->{channels} || 3;
2428 unless ($channels >= 1 && $channels <= 4) {
2429 return Imager->_set_error("channels must be an integer between 1 and 4");
2430 }
9982a307 2431
bf94b653 2432 my $img = Imager->new();
e5744e01
TC		 2433 $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2434 $channels, $code->code(),
bf94b653
TC		 2435 $code->nregs(), $code->cregs(),
2436 [ map { $_->{IMG} } @imgs ]);
2437 if (!defined $img->{IMG}) {
2438 $Imager::ERRSTR = Imager->_error_as_msg();
2439 return;
2440 }
9982a307 2441
bf94b653 2442 return $img;
02d1d628
AMH		 2443}
2444
02d1d628
AMH		 2445sub rubthrough {
2446 my $self=shift;
9b1ec2b8 2447 my %opts= @_;
02d1d628 2448
e7b95388
TC		 2449 unless ($self->{IMG}) {
2450 $self->{ERRSTR}='empty input image';
2451 return undef;
2452 }
2453 unless ($opts{src} && $opts{src}->{IMG}) {
2454 $self->{ERRSTR}='empty input image for src';
2455 return undef;
2456 }
02d1d628 2457
71dc4a83
AMH		 2458 %opts = (src_minx => 0,
2459 src_miny => 0,
2460 src_maxx => $opts{src}->getwidth(),
2461 src_maxy => $opts{src}->getheight(),
2462 %opts);
2463
9b1ec2b8
TC		 2464 my $tx = $opts{tx};
2465 defined $tx or $tx = $opts{left};
2466 defined $tx or $tx = 0;
2467
2468 my $ty = $opts{ty};
2469 defined $ty or $ty = $opts{top};
2470 defined $ty or $ty = 0;
2471
2472 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
e7b95388
TC		 2473 $opts{src_minx}, $opts{src_miny},
2474 $opts{src_maxx}, $opts{src_maxy})) {
2475 $self->_set_error($self->_error_as_msg());
faa9b3e7
TC		 2476 return undef;
2477 }
9b1ec2b8 2478
02d1d628
AMH		 2479 return $self;
2480}
2481
9b1ec2b8
TC		 2482sub compose {
2483 my $self = shift;
2484 my %opts =
2485 (
2486 opacity => 1.0,
2487 mask_left => 0,
2488 mask_top => 0,
2489 @_
2490 );
2491
2492 unless ($self->{IMG}) {
2493 $self->_set_error("compose: empty input image");
2494 return;
2495 }
2496
2497 unless ($opts{src}) {
2498 $self->_set_error("compose: src parameter missing");
2499 return;
2500 }
2501
2502 unless ($opts{src}{IMG}) {
2503 $self->_set_error("compose: src parameter empty image");
2504 return;
2505 }
2506 my $src = $opts{src};
2507
2508 my $left = $opts{left};
2509 defined $left or $left = $opts{tx};
2510 defined $left or $left = 0;
2511
2512 my $top = $opts{top};
2513 defined $top or $top = $opts{ty};
2514 defined $top or $top = 0;
2515
2516 my $src_left = $opts{src_left};
2517 defined $src_left or $src_left = $opts{src_minx};
2518 defined $src_left or $src_left = 0;
2519
2520 my $src_top = $opts{src_top};
2521 defined $src_top or $src_top = $opts{src_miny};
2522 defined $src_top or $src_top = 0;
2523
2524 my $width = $opts{width};
2525 if (!defined $width && defined $opts{src_maxx}) {
2526 $width = $opts{src_maxx} - $src_left;
2527 }
2528 defined $width or $width = $src->getwidth() - $src_left;
2529
2530 my $height = $opts{height};
2531 if (!defined $height && defined $opts{src_maxy}) {
2532 $height = $opts{src_maxy} - $src_top;
2533 }
2534 defined $height or $height = $src->getheight() - $src_top;
2535
2536 my $combine = $self->_combine($opts{combine}, 'normal');
2537
2538 if ($opts{mask}) {
2539 unless ($opts{mask}{IMG}) {
2540 $self->_set_error("compose: mask parameter empty image");
2541 return;
2542 }
2543
2544 my $mask_left = $opts{mask_left};
2545 defined $mask_left or $mask_left = $opts{mask_minx};
2546 defined $mask_left or $mask_left = 0;
2547
2548 my $mask_top = $opts{mask_top};
2549 defined $mask_top or $mask_top = $opts{mask_miny};
2550 defined $mask_top or $mask_top = 0;
2551
2552 i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
2553 $left, $top, $src_left, $src_top,
2554 $mask_left, $mask_top, $width, $height,
2555 $combine, $opts{opacity})
2556 or return;
2557 }
2558 else {
2559 i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2560 $width, $height, $combine, $opts{opacity})
2561 or return;
2562 }
2563
2564 return $self;
2565}
02d1d628 2566
142c26ff
AMH		 2567sub flip {
2568 my $self = shift;
2569 my %opts = @_;
9191e525 2570 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH		 2571 my $dir;
2572 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2573 $dir = $xlate{$opts{'dir'}};
2574 return $self if i_flipxy($self->{IMG}, $dir);
2575 return ();
2576}
2577
faa9b3e7
TC		 2578sub rotate {
2579 my $self = shift;
2580 my %opts = @_;
34b3f7e6
TC		 2581
2582 unless (defined wantarray) {
2583 my @caller = caller;
2584 warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2585 return;
2586 }
2587
faa9b3e7
TC		 2588 if (defined $opts{right}) {
2589 my $degrees = $opts{right};
2590 if ($degrees < 0) {
2591 $degrees += 360 * int(((-$degrees)+360)/360);
2592 }
2593 $degrees = $degrees % 360;
2594 if ($degrees == 0) {
2595 return $self->copy();
2596 }
2597 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2598 my $result = Imager->new();
2599 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2600 return $result;
2601 }
2602 else {
2603 $self->{ERRSTR} = $self->_error_as_msg();
2604 return undef;
2605 }
2606 }
2607 else {
2608 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2609 return undef;
2610 }
2611 }
2612 elsif (defined $opts{radians} || defined $opts{degrees}) {
2613 my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2614
7f627571 2615 my $back = $opts{back};
faa9b3e7 2616 my $result = Imager->new;
7f627571
TC		 2617 if ($back) {
2618 $back = _color($back);
2619 unless ($back) {
2620 $self->_set_error(Imager->errstr);
2621 return undef;
2622 }
2623
2624 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
0d3b936e
TC		 2625 }
2626 else {
2627 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2628 }
2629 if ($result->{IMG}) {
faa9b3e7
TC		 2630 return $result;
2631 }
2632 else {
2633 $self->{ERRSTR} = $self->_error_as_msg();
2634 return undef;
2635 }
2636 }
2637 else {
0d3b936e 2638 $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
faa9b3e7
TC		 2639 return undef;
2640 }
2641}
2642
2643sub matrix_transform {
2644 my $self = shift;
2645 my %opts = @_;
2646
34b3f7e6
TC		 2647 unless (defined wantarray) {
2648 my @caller = caller;
2649 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2650 return;
2651 }
2652
faa9b3e7
TC		 2653 if ($opts{matrix}) {
2654 my $xsize = $opts{xsize} || $self->getwidth;
2655 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 2656
faa9b3e7 2657 my $result = Imager->new;
0d3b936e
TC		 2658 if ($opts{back}) {
2659 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2660 $opts{matrix}, $opts{back})
2661 or return undef;
2662 }
2663 else {
2664 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2665 $opts{matrix})
2666 or return undef;
2667 }
faa9b3e7
TC		 2668
2669 return $result;
2670 }
2671 else {
2672 $self->{ERRSTR} = "matrix parameter required";
2673 return undef;
2674 }
2675}
2676
2677# blame Leolo :)
2678*yatf = \&matrix_transform;
02d1d628
AMH		 2679
2680# These two are supported for legacy code only
2681
2682sub i_color_new {
faa9b3e7 2683 return Imager::Color->new(@_);
02d1d628
AMH		 2684}
2685
2686sub i_color_set {
faa9b3e7 2687 return Imager::Color::set(@_);
02d1d628
AMH		 2688}
2689
02d1d628 2690# Draws a box between the specified corner points.
02d1d628
AMH		 2691sub box {
2692 my $self=shift;
2693 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2694 my $dflcl=i_color_new(255,255,255,255);
2695 my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2696
2697 if (exists $opts{'box'}) {
bf1573f9
TC		 2698 $opts{'xmin'} = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2699 $opts{'xmax'} = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2700 $opts{'ymin'} = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2701 $opts{'ymax'} = _max($opts{'box'}->[1],$opts{'box'}->[3]);
02d1d628
AMH		 2702 }
2703
f1ac5027 2704 if ($opts{filled}) {
3a9a4241
TC		 2705 my $color = _color($opts{'color'});
2706 unless ($color) {
2707 $self->{ERRSTR} = $Imager::ERRSTR;
2708 return;
2709 }
f1ac5027 2710 i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
3a9a4241 2711 $opts{ymax}, $color);
f1ac5027
TC		 2712 }
2713 elsif ($opts{fill}) {
2714 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2715 # assume it's a hash ref
2716 require 'Imager/Fill.pm';
141a6114
TC		 2717 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2718 $self->{ERRSTR} = $Imager::ERRSTR;
2719 return undef;
2720 }
f1ac5027
TC		 2721 }
2722 i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2723 $opts{ymax},$opts{fill}{fill});
2724 }
cdd23610 2725 else {
3a9a4241
TC		 2726 my $color = _color($opts{'color'});
2727 unless ($color) {
cdd23610
AMH		 2728 $self->{ERRSTR} = $Imager::ERRSTR;
2729 return;
3a9a4241
TC		 2730 }
2731 i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2732 $color);
f1ac5027 2733 }
02d1d628
AMH		 2734 return $self;
2735}
2736
02d1d628
AMH		 2737sub arc {
2738 my $self=shift;
2739 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2740 my $dflcl=i_color_new(255,255,255,255);
2741 my %opts=(color=>$dflcl,
bf1573f9 2742 'r'=>_min($self->getwidth(),$self->getheight())/3,
02d1d628
AMH		 2743 'x'=>$self->getwidth()/2,
2744 'y'=>$self->getheight()/2,
2745 'd1'=>0, 'd2'=>361, @_);
a8652edf
TC		 2746 if ($opts{aa}) {
2747 if ($opts{fill}) {
2748 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2749 # assume it's a hash ref
2750 require 'Imager/Fill.pm';
2751 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2752 $self->{ERRSTR} = $Imager::ERRSTR;
2753 return;
2754 }
2755 }
2756 i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2757 $opts{'d2'}, $opts{fill}{fill});
2758 }
2759 else {
2760 my $color = _color($opts{'color'});
2761 unless ($color) {
2762 $self->{ERRSTR} = $Imager::ERRSTR;
2763 return;
2764 }
2765 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2766 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2767 $color);
2768 }
2769 else {
2770 i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2771 $opts{'d1'}, $opts{'d2'}, $color);
569795e8 2772 }
f1ac5027 2773 }
f1ac5027
TC		 2774 }
2775 else {
a8652edf
TC		 2776 if ($opts{fill}) {
2777 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2778 # assume it's a hash ref
2779 require 'Imager/Fill.pm';
2780 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2781 $self->{ERRSTR} = $Imager::ERRSTR;
2782 return;
2783 }
2784 }
2785 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2786 $opts{'d2'}, $opts{fill}{fill});
0d321238
TC		 2787 }
2788 else {
a8652edf
TC		 2789 my $color = _color($opts{'color'});
2790 unless ($color) {
2791 $self->{ERRSTR} = $Imager::ERRSTR;
2792 return;
2793 }
c5baef69
TC		 2794 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2795 $opts{'d1'}, $opts{'d2'}, $color);
0d321238 2796 }
f1ac5027
TC		 2797 }
2798
02d1d628
AMH		 2799 return $self;
2800}
2801
aa833c97
AMH		 2802# Draws a line from one point to the other
2803# the endpoint is set if the endp parameter is set which it is by default.
2804# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH		 2805
2806sub line {
2807 my $self=shift;
2808 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH		 2809 my %opts=(color=>$dflcl,
2810 endp => 1,
2811 @_);
02d1d628
AMH		 2812 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2813
2814 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2815 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2816
3a9a4241 2817 my $color = _color($opts{'color'});
aa833c97
AMH		 2818 unless ($color) {
2819 $self->{ERRSTR} = $Imager::ERRSTR;
2820 return;
3a9a4241 2821 }
aa833c97 2822
3a9a4241 2823 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 2824 if ($opts{antialias}) {
aa833c97 2825 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 2826 $color, $opts{endp});
02d1d628 2827 } else {
aa833c97
AMH		 2828 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2829 $color, $opts{endp});
02d1d628
AMH		 2830 }
2831 return $self;
2832}
2833
2834# Draws a line between an ordered set of points - It more or less just transforms this
2835# into a list of lines.
2836
2837sub polyline {
2838 my $self=shift;
2839 my ($pt,$ls,@points);
2840 my $dflcl=i_color_new(0,0,0,0);
2841 my %opts=(color=>$dflcl,@_);
2842
2843 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2844
2845 if (exists($opts{points})) { @points=@{$opts{points}}; }
2846 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2847 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2848 }
2849
2850# print Dumper(\@points);
2851
3a9a4241
TC		 2852 my $color = _color($opts{'color'});
2853 unless ($color) {
2854 $self->{ERRSTR} = $Imager::ERRSTR;
2855 return;
2856 }
2857 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH		 2858 if ($opts{antialias}) {
2859 for $pt(@points) {
3a9a4241 2860 if (defined($ls)) {
b437ce0a 2861 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 2862 }
02d1d628
AMH		 2863 $ls=$pt;
2864 }
2865 } else {
2866 for $pt(@points) {
3a9a4241 2867 if (defined($ls)) {
aa833c97 2868 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 2869 }
02d1d628
AMH		 2870 $ls=$pt;
2871 }
2872 }
2873 return $self;
2874}
2875
d0e7bfee
AMH		 2876sub polygon {
2877 my $self = shift;
2878 my ($pt,$ls,@points);
2879 my $dflcl = i_color_new(0,0,0,0);
2880 my %opts = (color=>$dflcl, @_);
2881
2882 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2883
2884 if (exists($opts{points})) {
2885 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2886 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2887 }
2888
2889 if (!exists $opts{'x'} or !exists $opts{'y'}) {
2890 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2891 }
2892
43c5dacb
TC		 2893 if ($opts{'fill'}) {
2894 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2895 # assume it's a hash ref
2896 require 'Imager/Fill.pm';
2897 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2898 $self->{ERRSTR} = $Imager::ERRSTR;
2899 return undef;
2900 }
2901 }
2902 i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2903 $opts{'fill'}{'fill'});
2904 }
2905 else {
3a9a4241
TC		 2906 my $color = _color($opts{'color'});
2907 unless ($color) {
2908 $self->{ERRSTR} = $Imager::ERRSTR;
2909 return;
2910 }
2911 i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
43c5dacb
TC		 2912 }
2913
d0e7bfee
AMH		 2914 return $self;
2915}
2916
2917
2918# this the multipoint bezier curve
02d1d628
AMH		 2919# this is here more for testing that actual usage since
2920# this is not a good algorithm. Usually the curve would be
2921# broken into smaller segments and each done individually.
2922
2923sub polybezier {
2924 my $self=shift;
2925 my ($pt,$ls,@points);
2926 my $dflcl=i_color_new(0,0,0,0);
2927 my %opts=(color=>$dflcl,@_);
2928
2929 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2930
2931 if (exists $opts{points}) {
2932 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2933 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2934 }
2935
2936 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2937 $self->{ERRSTR}='Missing or invalid points.';
2938 return;
2939 }
2940
3a9a4241
TC		 2941 my $color = _color($opts{'color'});
2942 unless ($color) {
2943 $self->{ERRSTR} = $Imager::ERRSTR;
2944 return;
2945 }
2946 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH		 2947 return $self;
2948}
2949
cc6483e0
TC		 2950sub flood_fill {
2951 my $self = shift;
2952 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH		 2953 my $rc;
2954
9d540150 2955 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC		 2956 $self->{ERRSTR} = "missing seed x and y parameters";
2957 return undef;
2958 }
07d70837 2959
3efb0915
TC		 2960 if ($opts{border}) {
2961 my $border = _color($opts{border});
2962 unless ($border) {
2963 $self->_set_error($Imager::ERRSTR);
2964 return;
2965 }
2966 if ($opts{fill}) {
2967 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2968 # assume it's a hash ref
2969 require Imager::Fill;
2970 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2971 $self->{ERRSTR} = $Imager::ERRSTR;
2972 return;
2973 }
569795e8 2974 }
3efb0915
TC		 2975 $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2976 $opts{fill}{fill}, $border);
2977 }
2978 else {
2979 my $color = _color($opts{'color'});
2980 unless ($color) {
2981 $self->{ERRSTR} = $Imager::ERRSTR;
2982 return;
2983 }
2984 $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2985 $color, $border);
2986 }
2987 if ($rc) {
2988 return $self;
2989 }
2990 else {
2991 $self->{ERRSTR} = $self->_error_as_msg();
2992 return;
cc6483e0 2993 }
cc6483e0
TC		 2994 }
2995 else {
3efb0915
TC		 2996 if ($opts{fill}) {
2997 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2998 # assume it's a hash ref
2999 require 'Imager/Fill.pm';
3000 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3001 $self->{ERRSTR} = $Imager::ERRSTR;
3002 return;
3003 }
3004 }
3005 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3006 }
3007 else {
3008 my $color = _color($opts{'color'});
3009 unless ($color) {
3010 $self->{ERRSTR} = $Imager::ERRSTR;
3011 return;
3012 }
3013 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3014 }
3015 if ($rc) {
3016 return $self;
3017 }
3018 else {
3019 $self->{ERRSTR} = $self->_error_as_msg();
aa833c97 3020 return;
3a9a4241 3021 }
3efb0915 3022 }
cc6483e0
TC		 3023}
3024
591b5954
TC		 3025sub setpixel {
3026 my $self = shift;
3027
3028 my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
3029
3030 unless (exists $opts{'x'} && exists $opts{'y'}) {
3031 $self->{ERRSTR} = 'missing x and y parameters';
3032 return undef;
3033 }
3034
3035 my $x = $opts{'x'};
3036 my $y = $opts{'y'};
3037 my $color = _color($opts{color})
3038 or return undef;
3039 if (ref $x && ref $y) {
3040 unless (@$x == @$y) {
9650c424 3041 $self->{ERRSTR} = 'length of x and y mismatch';
837a4b43 3042 return;
591b5954 3043 }
837a4b43 3044 my $set = 0;
591b5954
TC		 3045 if ($color->isa('Imager::Color')) {
3046 for my $i (0..$#{$opts{'x'}}) {
837a4b43
TC		 3047 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3048 or ++$set;
591b5954
TC		 3049 }
3050 }
3051 else {
3052 for my $i (0..$#{$opts{'x'}}) {
837a4b43
TC		 3053 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3054 or ++$set;
591b5954
TC		 3055 }
3056 }
837a4b43
TC		 3057 $set or return;
3058 return $set;
591b5954
TC		 3059 }
3060 else {
3061 if ($color->isa('Imager::Color')) {
837a4b43
TC		 3062 i_ppix($self->{IMG}, $x, $y, $color)
3063 and return;
591b5954
TC		 3064 }
3065 else {
837a4b43
TC		 3066 i_ppixf($self->{IMG}, $x, $y, $color)
3067 and return;
591b5954
TC		 3068 }
3069 }
3070
3071 $self;
3072}
3073
3074sub getpixel {
3075 my $self = shift;
3076
a9fa203f 3077 my %opts = ( "type"=>'8bit', @_);
591b5954
TC		 3078
3079 unless (exists $opts{'x'} && exists $opts{'y'}) {
3080 $self->{ERRSTR} = 'missing x and y parameters';
3081 return undef;
3082 }
3083
3084 my $x = $opts{'x'};
3085 my $y = $opts{'y'};
3086 if (ref $x && ref $y) {
3087 unless (@$x == @$y) {
3088 $self->{ERRSTR} = 'length of x and y mismatch';
3089 return undef;
3090 }
3091 my @result;
a9fa203f 3092 if ($opts{"type"} eq '8bit') {
591b5954
TC		 3093 for my $i (0..$#{$opts{'x'}}) {
3094 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3095 }
3096 }
3097 else {
3098 for my $i (0..$#{$opts{'x'}}) {
3099 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3100 }
3101 }
3102 return wantarray ? @result : \@result;
3103 }
3104 else {
a9fa203f 3105 if ($opts{"type"} eq '8bit') {
591b5954
TC		 3106 return i_get_pixel($self->{IMG}, $x, $y);
3107 }
3108 else {
3109 return i_gpixf($self->{IMG}, $x, $y);
3110 }
3111 }
3112
3113 $self;
3114}
3115
ca4d914e
TC		 3116sub getscanline {
3117 my $self = shift;
3118 my %opts = ( type => '8bit', x=>0, @_);
3119
4cda4e76
TC		 3120 $self->_valid_image or return;
3121
ca4d914e
TC		 3122 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3123
3124 unless (defined $opts{'y'}) {
3125 $self->_set_error("missing y parameter");
3126 return;
3127 }
3128
3129 if ($opts{type} eq '8bit') {
3130 return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76 3131 $opts{'y'});
ca4d914e
TC		 3132 }
3133 elsif ($opts{type} eq 'float') {
3134 return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76
TC		 3135 $opts{'y'});
3136 }
3137 elsif ($opts{type} eq 'index') {
3138 unless (i_img_type($self->{IMG})) {
3139 $self->_set_error("type => index only valid on paletted images");
3140 return;
3141 }
3142 return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3143 $opts{'y'});
ca4d914e
TC		 3144 }
3145 else {
3146 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3147 return;
3148 }
3149}
3150
3151sub setscanline {
3152 my $self = shift;
3153 my %opts = ( x=>0, @_);
3154
4cda4e76
TC		 3155 $self->_valid_image or return;
3156
ca4d914e
TC		 3157 unless (defined $opts{'y'}) {
3158 $self->_set_error("missing y parameter");
3159 return;
3160 }
3161
3162 if (!$opts{type}) {
3163 if (ref $opts{pixels} && @{$opts{pixels}}) {
3164 # try to guess the type
3165 if ($opts{pixels}[0]->isa('Imager::Color')) {
3166 $opts{type} = '8bit';
3167 }
3168 elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3169 $opts{type} = 'float';
3170 }
3171 else {
3172 $self->_set_error("missing type parameter and could not guess from pixels");
3173 return;
3174 }
3175 }
3176 else {
3177 # default
3178 $opts{type} = '8bit';
3179 }
3180 }
3181
3182 if ($opts{type} eq '8bit') {
3183 if (ref $opts{pixels}) {
3184 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3185 }
3186 else {
3187 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3188 }
3189 }
3190 elsif ($opts{type} eq 'float') {
3191 if (ref $opts{pixels}) {
3192 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3193 }
3194 else {
3195 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3196 }
3197 }
4cda4e76
TC		 3198 elsif ($opts{type} eq 'index') {
3199 if (ref $opts{pixels}) {
3200 return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3201 }
3202 else {
3203 return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3204 }
3205 }
ca4d914e
TC		 3206 else {
3207 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3208 return;
3209 }
3210}
3211
3212sub getsamples {
3213 my $self = shift;
bd8052a6 3214 my %opts = ( type => '8bit', x=>0, offset => 0, @_);
ca4d914e
TC		 3215
3216 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3217
3218 unless (defined $opts{'y'}) {
3219 $self->_set_error("missing y parameter");
3220 return;
3221 }
3222
3223 unless ($opts{channels}) {
3224 $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3225 }
3226
bd8052a6
TC		 3227 if ($opts{target}) {
3228 my $target = $opts{target};
3229 my $offset = $opts{offset};
3230 if ($opts{type} eq '8bit') {
3231 my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3232 $opts{y}, @{$opts{channels}})
3233 or return;
3234 @{$target}{$offset .. $offset + @samples - 1} = @samples;
3235 return scalar(@samples);
3236 }
3237 elsif ($opts{type} eq 'float') {
3238 my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3239 $opts{y}, @{$opts{channels}});
3240 @{$target}{$offset .. $offset + @samples - 1} = @samples;
3241 return scalar(@samples);
3242 }
3243 elsif ($opts{type} =~ /^(\d+)bit$/) {
3244 my $bits = $1;
3245
3246 my @data;
3247 my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3248 $opts{y}, $bits, $target,
3249 $offset, @{$opts{channels}});
3250 unless (defined $count) {
3251 $self->_set_error(Imager->_error_as_msg);
3252 return;
3253 }
3254
3255 return $count;
3256 }
3257 else {
3258 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3259 return;
3260 }
ca4d914e
TC		 3261 }
3262 else {
bd8052a6
TC		 3263 if ($opts{type} eq '8bit') {
3264 return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3265 $opts{y}, @{$opts{channels}});
3266 }
3267 elsif ($opts{type} eq 'float') {
3268 return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3269 $opts{y}, @{$opts{channels}});
3270 }
3271 elsif ($opts{type} =~ /^(\d+)bit$/) {
3272 my $bits = $1;
3273
3274 my @data;
3275 i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3276 $opts{y}, $bits, \@data, 0, @{$opts{channels}})
3277 or return;
3278 return @data;
3279 }
3280 else {
3281 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3282 return;
3283 }
3284 }
3285}
3286
3287sub setsamples {
3288 my $self = shift;
3289 my %opts = ( x => 0, offset => 0, @_ );
3290
3291 unless ($self->{IMG}) {
3292 $self->_set_error('setsamples: empty input image');
3293 return;
3294 }
3295
3296 unless(defined $opts{data} && ref $opts{data}) {
3297 $self->_set_error('setsamples: data parameter missing or invalid');
ca4d914e
TC		 3298 return;
3299 }
bd8052a6
TC		 3300
3301 unless ($opts{channels}) {
3302 $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3303 }
3304
3305 unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) {
3306 $self->_set_error('setsamples: type parameter missing or invalid');
3307 return;
3308 }
3309 my $bits = $1;
3310
3311 unless (defined $opts{width}) {
3312 $opts{width} = $self->getwidth() - $opts{x};
3313 }
3314
3315 my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3316 $opts{channels}, $opts{data}, $opts{offset},
3317 $opts{width});
3318 unless (defined $count) {
3319 $self->_set_error(Imager->_error_as_msg);
3320 return;
3321 }
3322
3323 return $count;
ca4d914e
TC		 3324}
3325
f5991c03
TC		 3326# make an identity matrix of the given size
3327sub _identity {
3328 my ($size) = @_;
3329
3330 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3331 for my $c (0 .. ($size-1)) {
3332 $matrix->[$c][$c] = 1;
3333 }
3334 return $matrix;
3335}
3336
3337# general function to convert an image
3338sub convert {
3339 my ($self, %opts) = @_;
3340 my $matrix;
3341
34b3f7e6
TC		 3342 unless (defined wantarray) {
3343 my @caller = caller;
3344 warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3345 return;
3346 }
3347
f5991c03
TC		 3348 # the user can either specify a matrix or preset
3349 # the matrix overrides the preset
3350 if (!exists($opts{matrix})) {
3351 unless (exists($opts{preset})) {
3352 $self->{ERRSTR} = "convert() needs a matrix or preset";
3353 return;
3354 }
3355 else {
3356 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3357 # convert to greyscale, keeping the alpha channel if any
3358 if ($self->getchannels == 3) {
3359 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3360 }
3361 elsif ($self->getchannels == 4) {
3362 # preserve the alpha channel
3363 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3364 [ 0, 0, 0, 1 ] ];
3365 }
3366 else {
3367 # an identity
3368 $matrix = _identity($self->getchannels);
3369 }
3370 }
3371 elsif ($opts{preset} eq 'noalpha') {
3372 # strip the alpha channel
3373 if ($self->getchannels == 2 or $self->getchannels == 4) {
3374 $matrix = _identity($self->getchannels);
3375 pop(@$matrix); # lose the alpha entry
3376 }
3377 else {
3378 $matrix = _identity($self->getchannels);
3379 }
3380 }
3381 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3382 # extract channel 0
3383 $matrix = [ [ 1 ] ];
3384 }
3385 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3386 $matrix = [ [ 0, 1 ] ];
3387 }
3388 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3389 $matrix = [ [ 0, 0, 1 ] ];
3390 }
3391 elsif ($opts{preset} eq 'alpha') {
3392 if ($self->getchannels == 2 or $self->getchannels == 4) {
3393 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3394 }
3395 else {
3396 # the alpha is just 1 <shrug>
3397 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3398 }
3399 }
3400 elsif ($opts{preset} eq 'rgb') {
3401 if ($self->getchannels == 1) {
3402 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3403 }
3404 elsif ($self->getchannels == 2) {
3405 # preserve the alpha channel
3406 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3407 }
3408 else {
3409 $matrix = _identity($self->getchannels);
3410 }
3411 }
3412 elsif ($opts{preset} eq 'addalpha') {
3413 if ($self->getchannels == 1) {
3414 $matrix = _identity(2);
3415 }
3416 elsif ($self->getchannels == 3) {
3417 $matrix = _identity(4);
3418 }
3419 else {
3420 $matrix = _identity($self->getchannels);
3421 }
3422 }
3423 else {
3424 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3425 return undef;
3426 }
3427 }
3428 }
3429 else {
3430 $matrix = $opts{matrix};
3431 }
3432
d5477d3d
TC		 3433 my $new = Imager->new;
3434 $new->{IMG} = i_convert($self->{IMG}, $matrix);
3435 unless ($new->{IMG}) {
f5991c03
TC		 3436 # most likely a bad matrix
3437 $self->{ERRSTR} = _error_as_msg();
3438 return undef;
3439 }
3440 return $new;
3441}
40eba1ea
AMH		 3442
3443
40eba1ea 3444# general function to map an image through lookup tables
9495ee93 3445
40eba1ea
AMH		 3446sub map {
3447 my ($self, %opts) = @_;
9495ee93 3448 my @chlist = qw( red green blue alpha );
40eba1ea
AMH		 3449
3450 if (!exists($opts{'maps'})) {
3451 # make maps from channel maps
3452 my $chnum;
3453 for $chnum (0..$#chlist) {
9495ee93
AMH		 3454 if (exists $opts{$chlist[$chnum]}) {
3455 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3456 } elsif (exists $opts{'all'}) {
3457 $opts{'maps'}[$chnum] = $opts{'all'};
3458 }
40eba1ea
AMH		 3459 }
3460 }
3461 if ($opts{'maps'} and $self->{IMG}) {
3462 i_map($self->{IMG}, $opts{'maps'} );
3463 }
3464 return $self;
3465}
3466
dff75dee
TC		 3467sub difference {
3468 my ($self, %opts) = @_;
3469
3470 defined $opts{mindist} or $opts{mindist} = 0;
3471
3472 defined $opts{other}
3473 or return $self->_set_error("No 'other' parameter supplied");
3474 defined $opts{other}{IMG}
3475 or return $self->_set_error("No image data in 'other' image");
3476
3477 $self->{IMG}
3478 or return $self->_set_error("No image data");
3479
3480 my $result = Imager->new;
3481 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3482 $opts{mindist})
3483 or return $self->_set_error($self->_error_as_msg());
3484
3485 return $result;
3486}
3487
02d1d628
AMH		 3488# destructive border - image is shrunk by one pixel all around
3489
3490sub border {
3491 my ($self,%opts)=@_;
3492 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3493 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3494}
3495
3496
3497# Get the width of an image
3498
3499sub getwidth {
3500 my $self = shift;
3501 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3502 return (i_img_info($self->{IMG}))[0];
3503}
3504
3505# Get the height of an image
3506
3507sub getheight {
3508 my $self = shift;
3509 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3510 return (i_img_info($self->{IMG}))[1];
3511}
3512
3513# Get number of channels in an image
3514
3515sub getchannels {
3516 my $self = shift;
3517 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3518 return i_img_getchannels($self->{IMG});
3519}
3520
3521# Get channel mask
3522
3523sub getmask {
3524 my $self = shift;
3525 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3526 return i_img_getmask($self->{IMG});
3527}
3528
3529# Set channel mask
3530
3531sub setmask {
3532 my $self = shift;
3533 my %opts = @_;
35f40526
TC		 3534 if (!defined($self->{IMG})) {
3535 $self->{ERRSTR} = 'image is empty';
3536 return undef;
3537 }
3538 unless (defined $opts{mask}) {
3539 $self->_set_error("mask parameter required");
3540 return;
3541 }
02d1d628 3542 i_img_setmask( $self->{IMG} , $opts{mask} );
35f40526
TC		 3543
3544 1;
02d1d628
AMH		 3545}
3546
3547# Get number of colors in an image
3548
3549sub getcolorcount {
3550 my $self=shift;
9d540150 3551 my %opts=('maxcolors'=>2**30,@_);
02d1d628
AMH		 3552 if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3553 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3554 return ($rc==-1? undef : $rc);
3555}
3556
fe622da1
TC		 3557# Returns a reference to a hash. The keys are colour named (packed) and the
3558# values are the number of pixels in this colour.
3559sub getcolorusagehash {
a60905e4
TC		 3560 my $self = shift;
3561
3562 my %opts = ( maxcolors => 2**30, @_ );
3563 my $max_colors = $opts{maxcolors};
3564 unless (defined $max_colors && $max_colors > 0) {
3565 $self->_set_error('maxcolors must be a positive integer');
3566 return;
3567 }
3568
3569 unless (defined $self->{IMG}) {
3570 $self->_set_error('empty input image');
3571 return;
3572 }
3573
3574 my $channels= $self->getchannels;
3575 # We don't want to look at the alpha channel, because some gifs using it
3576 # doesn't define it for every colour (but only for some)
3577 $channels -= 1 if $channels == 2 or $channels == 4;
3578 my %color_use;
3579 my $height = $self->getheight;
3580 for my $y (0 .. $height - 1) {
3581 my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3582 while (length $colors) {
3583 $color_use{ substr($colors, 0, $channels, '') }++;
fe622da1 3584 }
a60905e4
TC		 3585 keys %color_use > $max_colors
3586 and return;
3587 }
3588 return \%color_use;
fe622da1
TC		 3589}
3590
3591# This will return a ordered array of the colour usage. Kind of the sorted
3592# version of the values of the hash returned by getcolorusagehash.
3593# You might want to add safety checks and change the names, etc...
3594sub getcolorusage {
a60905e4
TC		 3595 my $self = shift;
3596
3597 my %opts = ( maxcolors => 2**30, @_ );
3598 my $max_colors = $opts{maxcolors};
3599 unless (defined $max_colors && $max_colors > 0) {
3600 $self->_set_error('maxcolors must be a positive integer');
3601 return;
3602 }
3603
3604 unless (defined $self->{IMG}) {
3605 $self->_set_error('empty input image');
3606 return undef;
3607 }
3608
3609 return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
fe622da1
TC		 3610}
3611
02d1d628
AMH		 3612# draw string to an image
3613
3614sub string {
3615 my $self = shift;
3616 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3617
3618 my %input=('x'=>0, 'y'=>0, @_);
4314a320 3619 defined($input{string}) or $input{string} = $input{text};
02d1d628 3620
e922ae66 3621 unless(defined $input{string}) {
02d1d628
AMH		 3622 $self->{ERRSTR}="missing required parameter 'string'";
3623 return;
3624 }
3625
3626 unless($input{font}) {
3627 $self->{ERRSTR}="missing required parameter 'font'";
3628 return;
3629 }
3630
faa9b3e7 3631 unless ($input{font}->draw(image=>$self, %input)) {
faa9b3e7
TC		 3632 return;
3633 }
02d1d628
AMH		 3634
3635 return $self;
3636}
3637
a7ccc5e2
TC		 3638sub align_string {
3639 my $self = shift;
e922ae66
TC		 3640
3641 my $img;
3642 if (ref $self) {
3643 unless ($self->{IMG}) {
3644 $self->{ERRSTR}='empty input image';
3645 return;
3646 }
c9cb3397 3647 $img = $self;
e922ae66
TC		 3648 }
3649 else {
3650 $img = undef;
3651 }
a7ccc5e2
TC		 3652
3653 my %input=('x'=>0, 'y'=>0, @_);
3654 $input{string}||=$input{text};
3655
3656 unless(exists $input{string}) {
e922ae66 3657 $self->_set_error("missing required parameter 'string'");
a7ccc5e2
TC		 3658 return;
3659 }
3660
3661 unless($input{font}) {
e922ae66 3662 $self->_set_error("missing required parameter 'font'");
a7ccc5e2
TC		 3663 return;
3664 }
3665
3666 my @result;
e922ae66 3667 unless (@result = $input{font}->align(image=>$img, %input)) {
a7ccc5e2
TC		 3668 return;
3669 }
3670
3671 return wantarray ? @result : $result[0];
3672}
3673
77157728
TC		 3674my @file_limit_names = qw/width height bytes/;
3675
3676sub set_file_limits {
3677 shift;
3678
3679 my %opts = @_;
3680 my %values;
3681
3682 if ($opts{reset}) {
3683 @values{@file_limit_names} = (0) x @file_limit_names;
3684 }
3685 else {
3686 @values{@file_limit_names} = i_get_image_file_limits();
3687 }
3688
3689 for my $key (keys %values) {
3690 defined $opts{$key} and $values{$key} = $opts{$key};
3691 }
3692
3693 i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3694}
3695
3696sub get_file_limits {
3697 i_get_image_file_limits();
3698}
3699
02d1d628
AMH		 3700# Shortcuts that can be exported
3701
3702sub newcolor { Imager::Color->new(@_); }
3703sub newfont { Imager::Font->new(@_); }
bd8052a6 3704sub NCF { Imager::Color::Float->new(@_) }
02d1d628
AMH		 3705
3706*NC=*newcolour=*newcolor;
3707*NF=*newfont;
3708
3709*open=\&read;
3710*circle=\&arc;
3711
3712
3713#### Utility routines
3714
faa9b3e7
TC		 3715sub errstr {
3716 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3717}
02d1d628 3718
10461f9a
TC		 3719sub _set_error {
3720 my ($self, $msg) = @_;
3721
3722 if (ref $self) {
3723 $self->{ERRSTR} = $msg;
3724 }
3725 else {
3726 $ERRSTR = $msg;
3727 }
dff75dee 3728 return;
10461f9a
TC		 3729}
3730
02d1d628
AMH		 3731# Default guess for the type of an image from extension
3732
3733sub def_guess_type {
3734 my $name=lc(shift);
3735 my $ext;
3736 $ext=($name =~ m/\.([^\.]+)$/)[0];
3737 return 'tiff' if ($ext =~ m/^tiff?$/);
3738 return 'jpeg' if ($ext =~ m/^jpe?g$/);
3739 return 'pnm' if ($ext =~ m/^p[pgb]m$/);
3740 return 'png' if ($ext eq "png");
705fd961 3741 return 'bmp' if ($ext eq "bmp" || $ext eq "dib");
1ec86afa 3742 return 'tga' if ($ext eq "tga");
d5477d3d 3743 return 'sgi' if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
02d1d628 3744 return 'gif' if ($ext eq "gif");
10461f9a 3745 return 'raw' if ($ext eq "raw");
2b405c9e 3746 return lc $ext; # best guess
02d1d628
AMH		 3747 return ();
3748}
3749
9b1ec2b8
TC		 3750sub combines {
3751 return @combine_types;
3752}
3753
02d1d628
AMH		 3754# get the minimum of a list
3755
bf1573f9 3756sub _min {
02d1d628
AMH		 3757 my $mx=shift;
3758 for(@_) { if ($_<$mx) { $mx=$_; }}
3759 return $mx;
3760}
3761
3762# get the maximum of a list
3763
bf1573f9 3764sub _max {
02d1d628
AMH		 3765 my $mx=shift;
3766 for(@_) { if ($_>$mx) { $mx=$_; }}
3767 return $mx;
3768}
3769
3770# string stuff for iptc headers
3771
bf1573f9 3772sub _clean {
02d1d628
AMH		 3773 my($str)=$_[0];
3774 $str = substr($str,3);
3775 $str =~ s/[\n\r]//g;
3776 $str =~ s/\s+/ /g;
3777 $str =~ s/^\s//;
3778 $str =~ s/\s$//;
3779 return $str;
3780}
3781
3782# A little hack to parse iptc headers.
3783
3784sub parseiptc {
3785 my $self=shift;
3786 my(@sar,$item,@ar);
3787 my($caption,$photogr,$headln,$credit);
3788
3789 my $str=$self->{IPTCRAW};
3790
24ae6325
TC		 3791 defined $str
3792 or return;
02d1d628
AMH		 3793
3794 @ar=split(/8BIM/,$str);
3795
3796 my $i=0;
3797 foreach (@ar) {
3798 if (/^\004\004/) {
3799 @sar=split(/\034\002/);
3800 foreach $item (@sar) {
cdd23610 3801 if ($item =~ m/^x/) {
bf1573f9 3802 $caption = _clean($item);
02d1d628
AMH		 3803 $i++;
3804 }
cdd23610 3805 if ($item =~ m/^P/) {
bf1573f9 3806 $photogr = _clean($item);
02d1d628
AMH		 3807 $i++;
3808 }
cdd23610 3809 if ($item =~ m/^i/) {
bf1573f9 3810 $headln = _clean($item);
02d1d628
AMH		 3811 $i++;
3812 }
cdd23610 3813 if ($item =~ m/^n/) {
bf1573f9 3814 $credit = _clean($item);
02d1d628
AMH		 3815 $i++;
3816 }
3817 }
3818 }
3819 }
3820 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3821}
3822
92bda632
TC		 3823sub Inline {
3824 my ($lang) = @_;
3825
3826 $lang eq 'C'
3827 or die "Only C language supported";
3828
3829 require Imager::ExtUtils;
3830 return Imager::ExtUtils->inline_config;
3831}
02d1d628
AMH		 3832
38331;
3834__END__
3835# Below is the stub of documentation for your module. You better edit it!
3836
3837=head1 NAME
3838
3839Imager - Perl extension for Generating 24 bit Images
3840
3841=head1 SYNOPSIS
3842
0e418f1e
AMH		 3843 # Thumbnail example
3844
3845 #!/usr/bin/perl -w
3846 use strict;
10461f9a 3847 use Imager;
02d1d628 3848
0e418f1e
AMH		 3849 die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3850 my $file = shift;
3851
3852 my $format;
3853
3854 my $img = Imager->new();
e36d02ad
TC		 3855 # see Imager::Files for information on the read() method
3856 $img->read(file=>$file) or die $img->errstr();
0e418f1e
AMH		 3857
3858 $file =~ s/\.[^.]*$//;
3859
3860 # Create smaller version
cf7a7d18 3861 # documented in Imager::Transformations
0e418f1e
AMH		 3862 my $thumb = $img->scale(scalefactor=>.3);
3863
3864 # Autostretch individual channels
3865 $thumb->filter(type=>'autolevels');
3866
3867 # try to save in one of these formats
3868 SAVE:
3869
3870 for $format ( qw( png gif jpg tiff ppm ) ) {
3871 # Check if given format is supported
3872 if ($Imager::formats{$format}) {
3873 $file.="_low.$format";
3874 print "Storing image as: $file\n";
cf7a7d18 3875 # documented in Imager::Files
0e418f1e
AMH		 3876 $thumb->write(file=>$file) or
3877 die $thumb->errstr;
3878 last SAVE;
3879 }
3880 }
3881
02d1d628
AMH		 3882=head1 DESCRIPTION
3883
0e418f1e
AMH		 3884Imager is a module for creating and altering images. It can read and
3885write various image formats, draw primitive shapes like lines,and
3886polygons, blend multiple images together in various ways, scale, crop,
3887render text and more.
02d1d628 3888
5df0fac7
AMH		 3889=head2 Overview of documentation
3890
3891=over
3892
cf7a7d18 3893=item *
5df0fac7 3894
d5556805 3895Imager - This document - Synopsis, Example, Table of Contents and
cf7a7d18 3896Overview.
5df0fac7 3897
cf7a7d18 3898=item *
5df0fac7 3899
985bda61
TC		 3900L<Imager::Tutorial> - a brief introduction to Imager.
3901
3902=item *
3903
e1d57e9d
TC		 3904L<Imager::Cookbook> - how to do various things with Imager.
3905
3906=item *
3907
cf7a7d18
TC		 3908L<Imager::ImageTypes> - Basics of constructing image objects with
3909C<new()>: Direct type/virtual images, RGB(A)/paletted images,
39108/16/double bits/channel, color maps, channel masks, image tags, color
6d0ed98a 3911quantization. Also discusses basic image information methods.
5df0fac7 3912
cf7a7d18 3913=item *
5df0fac7 3914
cf7a7d18
TC		 3915L<Imager::Files> - IO interaction, reading/writing images, format
3916specific tags.
5df0fac7 3917
cf7a7d18 3918=item *
5df0fac7 3919
cf7a7d18
TC		 3920L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
3921flood fill.
5df0fac7 3922
cf7a7d18 3923=item *
5df0fac7 3924
cf7a7d18 3925L<Imager::Color> - Color specification.
5df0fac7 3926
cf7a7d18 3927=item *
f5fd108b 3928
cf7a7d18 3929L<Imager::Fill> - Fill pattern specification.
f5fd108b 3930
cf7a7d18 3931=item *
5df0fac7 3932
cf7a7d18
TC		 3933L<Imager::Font> - General font rendering, bounding boxes and font
3934metrics.
5df0fac7 3935
cf7a7d18 3936=item *
5df0fac7 3937
cf7a7d18
TC		 3938L<Imager::Transformations> - Copying, scaling, cropping, flipping,
3939blending, pasting, convert and map.
5df0fac7 3940
cf7a7d18 3941=item *
5df0fac7 3942
cf7a7d18
TC		 3943L<Imager::Engines> - Programmable transformations through
3944C<transform()>, C<transform2()> and C<matrix_transform()>.
5df0fac7 3945
cf7a7d18 3946=item *
5df0fac7 3947
cf7a7d18
TC		 3948L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
3949filter plugins.
5df0fac7 3950
cf7a7d18 3951=item *
5df0fac7 3952
cf7a7d18
TC		 3953L<Imager::Expr> - Expressions for evaluation engine used by
3954transform2().
5df0fac7 3955
cf7a7d18 3956=item *
5df0fac7 3957
cf7a7d18 3958L<Imager::Matrix2d> - Helper class for affine transformations.
5df0fac7 3959
cf7a7d18 3960=item *
5df0fac7 3961
cf7a7d18 3962L<Imager::Fountain> - Helper for making gradient profiles.
5df0fac7 3963
92bda632
TC		 3964=item *
3965
3966L<Imager::API> - using Imager's C API
3967
3968=item *
3969
3970L<Imager::APIRef> - API function reference
3971
3972=item *
3973
3974L<Imager::Inline> - using Imager's C API from Inline::C
3975
3976=item *
3977
3978L<Imager::ExtUtils> - tools to get access to Imager's C API.
3979
5df0fac7
AMH		 3980=back
3981
0e418f1e 3982=head2 Basic Overview
02d1d628 3983
55b287f5
AMH		 3984An Image object is created with C<$img = Imager-E<gt>new()>.
3985Examples:
02d1d628 3986
55b287f5 3987 $img=Imager->new(); # create empty image
e36d02ad 3988 $img->read(file=>'lena.png',type=>'png') or # read image from file
55b287f5
AMH		 3989 die $img->errstr(); # give an explanation
3990 # if something failed
02d1d628
AMH		 3991
3992or if you want to create an empty image:
3993
3994 $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3995
0e418f1e
AMH		 3996This example creates a completely black image of width 400 and height
3997300 and 4 channels.
3998
d5556805 3999=head1 ERROR HANDLING
55b287f5 4000
9b1ec2b8
TC		 4001In general a method will return false when it fails, if it does use
4002the errstr() method to find out why:
d5556805
TC		 4003
4004=over
4005
4006=item errstr
4007
4008Returns the last error message in that context.
4009
4010If the last error you received was from calling an object method, such
4011as read, call errstr() as an object method to find out why:
4012
4013 my $image = Imager->new;
4014 $image->read(file => 'somefile.gif')
4015 or die $image->errstr;
4016
4017If it was a class method then call errstr() as a class method:
4018
4019 my @imgs = Imager->read_multi(file => 'somefile.gif')
4020 or die Imager->errstr;
4021
4022Note that in some cases object methods are implemented in terms of
4023class methods so a failing object method may set both.
4024
4025=back
55b287f5 4026
cf7a7d18
TC		 4027The C<Imager-E<gt>new> method is described in detail in
4028L<Imager::ImageTypes>.
4b4f5319 4029
13fc481e
TC		 4030=head1 METHOD INDEX
4031
4032Where to find information on methods for Imager class objects.
4033
4b3408a5 4034addcolors() - L<Imager::ImageTypes/addcolors>
13fc481e 4035
4b3408a5 4036addtag() - L<Imager::ImageTypes/addtag> - add image tags
13fc481e 4037
a7ccc5e2
TC		 4038align_string() - L<Imager::Draw/align_string>
4039
7fca1e9e
TC		 4040arc() - L<Imager::Draw/arc>
4041
4b3408a5 4042bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
13fc481e
TC		 4043image
4044
4045box() - L<Imager::Draw/box>
4046
4047circle() - L<Imager::Draw/circle>
4048
feac660c
TC		 4049colorcount() - L<Imager::Draw/colorcount>
4050
9b1ec2b8
TC		 4051combines() - L<Imager::Draw/combines>
4052
4053compose() - L<Imager::Transformations/compose>
4054
13fc481e
TC		 4055convert() - L<Imager::Transformations/"Color transformations"> -
4056transform the color space
4057
4058copy() - L<Imager::Transformations/copy>
4059
4060crop() - L<Imager::Transformations/crop> - extract part of an image
4061
d5556805
TC		 4062def_guess_type() - L<Imager::Files/def_guess_type>
4063
4b3408a5 4064deltag() - L<Imager::ImageTypes/deltag> - delete image tags
13fc481e
TC		 4065
4066difference() - L<Imager::Filters/"Image Difference">
4067
e922ae66 4068errstr() - L<"Basic Overview">
99958502 4069
13fc481e
TC		 4070filter() - L<Imager::Filters>
4071
4b3408a5 4072findcolor() - L<Imager::ImageTypes/findcolor> - search the image palette, if it
13fc481e
TC		 4073has one
4074
4075flip() - L<Imager::Transformations/flip>
4076
4077flood_fill() - L<Imager::Draw/flood_fill>
4078
4b3408a5 4079getchannels() - L<Imager::ImageTypes/getchannels>
13fc481e