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