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