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