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