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