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