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