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