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