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