More support for autodetection of formats, still some error comes up in
[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
AMH
1026 if ( $input{'type'} eq 'jpeg' ) {
1027 ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_wiol( $IO );
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 }
9982a307 1725
bf94b653
TC
1726 my $img = Imager->new();
1727 $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, $code->code(),
1728 $code->nregs(), $code->cregs(),
1729 [ map { $_->{IMG} } @imgs ]);
1730 if (!defined $img->{IMG}) {
1731 $Imager::ERRSTR = Imager->_error_as_msg();
1732 return;
1733 }
9982a307 1734
bf94b653 1735 return $img;
02d1d628
AMH
1736}
1737
02d1d628
AMH
1738sub rubthrough {
1739 my $self=shift;
1740 my %opts=(tx=>0,ty=>0,@_);
1741
1742 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1743 unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1744
faa9b3e7
TC
1745 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx},$opts{ty})) {
1746 $self->{ERRSTR} = $self->_error_as_msg();
1747 return undef;
1748 }
02d1d628
AMH
1749 return $self;
1750}
1751
1752
142c26ff
AMH
1753sub flip {
1754 my $self = shift;
1755 my %opts = @_;
9191e525 1756 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH
1757 my $dir;
1758 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1759 $dir = $xlate{$opts{'dir'}};
1760 return $self if i_flipxy($self->{IMG}, $dir);
1761 return ();
1762}
1763
faa9b3e7
TC
1764sub rotate {
1765 my $self = shift;
1766 my %opts = @_;
1767 if (defined $opts{right}) {
1768 my $degrees = $opts{right};
1769 if ($degrees < 0) {
1770 $degrees += 360 * int(((-$degrees)+360)/360);
1771 }
1772 $degrees = $degrees % 360;
1773 if ($degrees == 0) {
1774 return $self->copy();
1775 }
1776 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1777 my $result = Imager->new();
1778 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1779 return $result;
1780 }
1781 else {
1782 $self->{ERRSTR} = $self->_error_as_msg();
1783 return undef;
1784 }
1785 }
1786 else {
1787 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1788 return undef;
1789 }
1790 }
1791 elsif (defined $opts{radians} || defined $opts{degrees}) {
1792 my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1793
1794 my $result = Imager->new;
1795 if ($result->{IMG} = i_rotate_exact($self->{IMG}, $amount)) {
1796 return $result;
1797 }
1798 else {
1799 $self->{ERRSTR} = $self->_error_as_msg();
1800 return undef;
1801 }
1802 }
1803 else {
1804 $self->{ERRSTR} = "Only the 'right' parameter is available";
1805 return undef;
1806 }
1807}
1808
1809sub matrix_transform {
1810 my $self = shift;
1811 my %opts = @_;
1812
1813 if ($opts{matrix}) {
1814 my $xsize = $opts{xsize} || $self->getwidth;
1815 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 1816
faa9b3e7
TC
1817 my $result = Imager->new;
1818 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1819 $opts{matrix})
1820 or return undef;
1821
1822 return $result;
1823 }
1824 else {
1825 $self->{ERRSTR} = "matrix parameter required";
1826 return undef;
1827 }
1828}
1829
1830# blame Leolo :)
1831*yatf = \&matrix_transform;
02d1d628
AMH
1832
1833# These two are supported for legacy code only
1834
1835sub i_color_new {
faa9b3e7 1836 return Imager::Color->new(@_);
02d1d628
AMH
1837}
1838
1839sub i_color_set {
faa9b3e7 1840 return Imager::Color::set(@_);
02d1d628
AMH
1841}
1842
02d1d628 1843# Draws a box between the specified corner points.
02d1d628
AMH
1844sub box {
1845 my $self=shift;
1846 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1847 my $dflcl=i_color_new(255,255,255,255);
1848 my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1849
1850 if (exists $opts{'box'}) {
1851 $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1852 $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1853 $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1854 $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1855 }
1856
f1ac5027 1857 if ($opts{filled}) {
3a9a4241
TC
1858 my $color = _color($opts{'color'});
1859 unless ($color) {
1860 $self->{ERRSTR} = $Imager::ERRSTR;
1861 return;
1862 }
f1ac5027 1863 i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
3a9a4241 1864 $opts{ymax}, $color);
f1ac5027
TC
1865 }
1866 elsif ($opts{fill}) {
1867 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1868 # assume it's a hash ref
1869 require 'Imager/Fill.pm';
141a6114
TC
1870 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1871 $self->{ERRSTR} = $Imager::ERRSTR;
1872 return undef;
1873 }
f1ac5027
TC
1874 }
1875 i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1876 $opts{ymax},$opts{fill}{fill});
1877 }
cdd23610 1878 else {
3a9a4241
TC
1879 my $color = _color($opts{'color'});
1880 unless ($color) {
cdd23610
AMH
1881 $self->{ERRSTR} = $Imager::ERRSTR;
1882 return;
3a9a4241
TC
1883 }
1884 i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
1885 $color);
f1ac5027 1886 }
02d1d628
AMH
1887 return $self;
1888}
1889
1890# Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
1891
1892sub arc {
1893 my $self=shift;
1894 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1895 my $dflcl=i_color_new(255,255,255,255);
1896 my %opts=(color=>$dflcl,
1897 'r'=>min($self->getwidth(),$self->getheight())/3,
1898 'x'=>$self->getwidth()/2,
1899 'y'=>$self->getheight()/2,
1900 'd1'=>0, 'd2'=>361, @_);
f1ac5027
TC
1901 if ($opts{fill}) {
1902 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1903 # assume it's a hash ref
1904 require 'Imager/Fill.pm';
569795e8
TC
1905 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1906 $self->{ERRSTR} = $Imager::ERRSTR;
1907 return;
1908 }
f1ac5027
TC
1909 }
1910 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
1911 $opts{'d2'}, $opts{fill}{fill});
1912 }
1913 else {
3a9a4241
TC
1914 my $color = _color($opts{'color'});
1915 unless ($color) {
1916 $self->{ERRSTR} = $Imager::ERRSTR;
1917 return;
1918 }
0d321238
TC
1919 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
1920 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
3a9a4241 1921 $color);
0d321238
TC
1922 }
1923 else {
3a9a4241
TC
1924 if ($opts{'d1'} <= $opts{'d2'}) {
1925 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1926 $opts{'d1'}, $opts{'d2'}, $color);
1927 }
1928 else {
1929 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1930 $opts{'d1'}, 361, $color);
1931 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1932 0, $opts{'d2'}, $color);
1933 }
0d321238 1934 }
f1ac5027
TC
1935 }
1936
02d1d628
AMH
1937 return $self;
1938}
1939
aa833c97
AMH
1940# Draws a line from one point to the other
1941# the endpoint is set if the endp parameter is set which it is by default.
1942# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH
1943
1944sub line {
1945 my $self=shift;
1946 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH
1947 my %opts=(color=>$dflcl,
1948 endp => 1,
1949 @_);
02d1d628
AMH
1950 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1951
1952 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
1953 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
1954
3a9a4241 1955 my $color = _color($opts{'color'});
aa833c97
AMH
1956 unless ($color) {
1957 $self->{ERRSTR} = $Imager::ERRSTR;
1958 return;
3a9a4241 1959 }
aa833c97 1960
3a9a4241 1961 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 1962 if ($opts{antialias}) {
aa833c97 1963 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 1964 $color, $opts{endp});
02d1d628 1965 } else {
aa833c97
AMH
1966 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
1967 $color, $opts{endp});
02d1d628
AMH
1968 }
1969 return $self;
1970}
1971
1972# Draws a line between an ordered set of points - It more or less just transforms this
1973# into a list of lines.
1974
1975sub polyline {
1976 my $self=shift;
1977 my ($pt,$ls,@points);
1978 my $dflcl=i_color_new(0,0,0,0);
1979 my %opts=(color=>$dflcl,@_);
1980
1981 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1982
1983 if (exists($opts{points})) { @points=@{$opts{points}}; }
1984 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
1985 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
1986 }
1987
1988# print Dumper(\@points);
1989
3a9a4241
TC
1990 my $color = _color($opts{'color'});
1991 unless ($color) {
1992 $self->{ERRSTR} = $Imager::ERRSTR;
1993 return;
1994 }
1995 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH
1996 if ($opts{antialias}) {
1997 for $pt(@points) {
3a9a4241 1998 if (defined($ls)) {
b437ce0a 1999 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 2000 }
02d1d628
AMH
2001 $ls=$pt;
2002 }
2003 } else {
2004 for $pt(@points) {
3a9a4241 2005 if (defined($ls)) {
aa833c97 2006 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 2007 }
02d1d628
AMH
2008 $ls=$pt;
2009 }
2010 }
2011 return $self;
2012}
2013
d0e7bfee
AMH
2014sub polygon {
2015 my $self = shift;
2016 my ($pt,$ls,@points);
2017 my $dflcl = i_color_new(0,0,0,0);
2018 my %opts = (color=>$dflcl, @_);
2019
2020 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2021
2022 if (exists($opts{points})) {
2023 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2024 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2025 }
2026
2027 if (!exists $opts{'x'} or !exists $opts{'y'}) {
2028 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2029 }
2030
43c5dacb
TC
2031 if ($opts{'fill'}) {
2032 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2033 # assume it's a hash ref
2034 require 'Imager/Fill.pm';
2035 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2036 $self->{ERRSTR} = $Imager::ERRSTR;
2037 return undef;
2038 }
2039 }
2040 i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2041 $opts{'fill'}{'fill'});
2042 }
2043 else {
3a9a4241
TC
2044 my $color = _color($opts{'color'});
2045 unless ($color) {
2046 $self->{ERRSTR} = $Imager::ERRSTR;
2047 return;
2048 }
2049 i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
43c5dacb
TC
2050 }
2051
d0e7bfee
AMH
2052 return $self;
2053}
2054
2055
2056# this the multipoint bezier curve
02d1d628
AMH
2057# this is here more for testing that actual usage since
2058# this is not a good algorithm. Usually the curve would be
2059# broken into smaller segments and each done individually.
2060
2061sub polybezier {
2062 my $self=shift;
2063 my ($pt,$ls,@points);
2064 my $dflcl=i_color_new(0,0,0,0);
2065 my %opts=(color=>$dflcl,@_);
2066
2067 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2068
2069 if (exists $opts{points}) {
2070 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2071 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2072 }
2073
2074 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2075 $self->{ERRSTR}='Missing or invalid points.';
2076 return;
2077 }
2078
3a9a4241
TC
2079 my $color = _color($opts{'color'});
2080 unless ($color) {
2081 $self->{ERRSTR} = $Imager::ERRSTR;
2082 return;
2083 }
2084 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH
2085 return $self;
2086}
2087
cc6483e0
TC
2088sub flood_fill {
2089 my $self = shift;
2090 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH
2091 my $rc;
2092
9d540150 2093 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC
2094 $self->{ERRSTR} = "missing seed x and y parameters";
2095 return undef;
2096 }
07d70837 2097
cc6483e0
TC
2098 if ($opts{fill}) {
2099 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2100 # assume it's a hash ref
2101 require 'Imager/Fill.pm';
569795e8
TC
2102 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2103 $self->{ERRSTR} = $Imager::ERRSTR;
2104 return;
2105 }
cc6483e0 2106 }
a321d497 2107 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
cc6483e0
TC
2108 }
2109 else {
3a9a4241 2110 my $color = _color($opts{'color'});
aa833c97
AMH
2111 unless ($color) {
2112 $self->{ERRSTR} = $Imager::ERRSTR;
2113 return;
3a9a4241 2114 }
a321d497 2115 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
cc6483e0 2116 }
aa833c97 2117 if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
cc6483e0
TC
2118}
2119
591b5954
TC
2120sub setpixel {
2121 my $self = shift;
2122
2123 my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2124
2125 unless (exists $opts{'x'} && exists $opts{'y'}) {
2126 $self->{ERRSTR} = 'missing x and y parameters';
2127 return undef;
2128 }
2129
2130 my $x = $opts{'x'};
2131 my $y = $opts{'y'};
2132 my $color = _color($opts{color})
2133 or return undef;
2134 if (ref $x && ref $y) {
2135 unless (@$x == @$y) {
9650c424 2136 $self->{ERRSTR} = 'length of x and y mismatch';
591b5954
TC
2137 return undef;
2138 }
2139 if ($color->isa('Imager::Color')) {
2140 for my $i (0..$#{$opts{'x'}}) {
2141 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2142 }
2143 }
2144 else {
2145 for my $i (0..$#{$opts{'x'}}) {
2146 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2147 }
2148 }
2149 }
2150 else {
2151 if ($color->isa('Imager::Color')) {
2152 i_ppix($self->{IMG}, $x, $y, $color);
2153 }
2154 else {
2155 i_ppixf($self->{IMG}, $x, $y, $color);
2156 }
2157 }
2158
2159 $self;
2160}
2161
2162sub getpixel {
2163 my $self = shift;
2164
a9fa203f 2165 my %opts = ( "type"=>'8bit', @_);
591b5954
TC
2166
2167 unless (exists $opts{'x'} && exists $opts{'y'}) {
2168 $self->{ERRSTR} = 'missing x and y parameters';
2169 return undef;
2170 }
2171
2172 my $x = $opts{'x'};
2173 my $y = $opts{'y'};
2174 if (ref $x && ref $y) {
2175 unless (@$x == @$y) {
2176 $self->{ERRSTR} = 'length of x and y mismatch';
2177 return undef;
2178 }
2179 my @result;
a9fa203f 2180 if ($opts{"type"} eq '8bit') {
591b5954
TC
2181 for my $i (0..$#{$opts{'x'}}) {
2182 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2183 }
2184 }
2185 else {
2186 for my $i (0..$#{$opts{'x'}}) {
2187 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2188 }
2189 }
2190 return wantarray ? @result : \@result;
2191 }
2192 else {
a9fa203f 2193 if ($opts{"type"} eq '8bit') {
591b5954
TC
2194 return i_get_pixel($self->{IMG}, $x, $y);
2195 }
2196 else {
2197 return i_gpixf($self->{IMG}, $x, $y);
2198 }
2199 }
2200
2201 $self;
2202}
2203
f5991c03
TC
2204# make an identity matrix of the given size
2205sub _identity {
2206 my ($size) = @_;
2207
2208 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2209 for my $c (0 .. ($size-1)) {
2210 $matrix->[$c][$c] = 1;
2211 }
2212 return $matrix;
2213}
2214
2215# general function to convert an image
2216sub convert {
2217 my ($self, %opts) = @_;
2218 my $matrix;
2219
2220 # the user can either specify a matrix or preset
2221 # the matrix overrides the preset
2222 if (!exists($opts{matrix})) {
2223 unless (exists($opts{preset})) {
2224 $self->{ERRSTR} = "convert() needs a matrix or preset";
2225 return;
2226 }
2227 else {
2228 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2229 # convert to greyscale, keeping the alpha channel if any
2230 if ($self->getchannels == 3) {
2231 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2232 }
2233 elsif ($self->getchannels == 4) {
2234 # preserve the alpha channel
2235 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2236 [ 0, 0, 0, 1 ] ];
2237 }
2238 else {
2239 # an identity
2240 $matrix = _identity($self->getchannels);
2241 }
2242 }
2243 elsif ($opts{preset} eq 'noalpha') {
2244 # strip the alpha channel
2245 if ($self->getchannels == 2 or $self->getchannels == 4) {
2246 $matrix = _identity($self->getchannels);
2247 pop(@$matrix); # lose the alpha entry
2248 }
2249 else {
2250 $matrix = _identity($self->getchannels);
2251 }
2252 }
2253 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2254 # extract channel 0
2255 $matrix = [ [ 1 ] ];
2256 }
2257 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2258 $matrix = [ [ 0, 1 ] ];
2259 }
2260 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2261 $matrix = [ [ 0, 0, 1 ] ];
2262 }
2263 elsif ($opts{preset} eq 'alpha') {
2264 if ($self->getchannels == 2 or $self->getchannels == 4) {
2265 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2266 }
2267 else {
2268 # the alpha is just 1 <shrug>
2269 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2270 }
2271 }
2272 elsif ($opts{preset} eq 'rgb') {
2273 if ($self->getchannels == 1) {
2274 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2275 }
2276 elsif ($self->getchannels == 2) {
2277 # preserve the alpha channel
2278 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2279 }
2280 else {
2281 $matrix = _identity($self->getchannels);
2282 }
2283 }
2284 elsif ($opts{preset} eq 'addalpha') {
2285 if ($self->getchannels == 1) {
2286 $matrix = _identity(2);
2287 }
2288 elsif ($self->getchannels == 3) {
2289 $matrix = _identity(4);
2290 }
2291 else {
2292 $matrix = _identity($self->getchannels);
2293 }
2294 }
2295 else {
2296 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2297 return undef;
2298 }
2299 }
2300 }
2301 else {
2302 $matrix = $opts{matrix};
2303 }
2304
2305 my $new = Imager->new();
2306 $new->{IMG} = i_img_new();
2307 unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2308 # most likely a bad matrix
2309 $self->{ERRSTR} = _error_as_msg();
2310 return undef;
2311 }
2312 return $new;
2313}
40eba1ea
AMH
2314
2315
40eba1ea 2316# general function to map an image through lookup tables
9495ee93 2317
40eba1ea
AMH
2318sub map {
2319 my ($self, %opts) = @_;
9495ee93 2320 my @chlist = qw( red green blue alpha );
40eba1ea
AMH
2321
2322 if (!exists($opts{'maps'})) {
2323 # make maps from channel maps
2324 my $chnum;
2325 for $chnum (0..$#chlist) {
9495ee93
AMH
2326 if (exists $opts{$chlist[$chnum]}) {
2327 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2328 } elsif (exists $opts{'all'}) {
2329 $opts{'maps'}[$chnum] = $opts{'all'};
2330 }
40eba1ea
AMH
2331 }
2332 }
2333 if ($opts{'maps'} and $self->{IMG}) {
2334 i_map($self->{IMG}, $opts{'maps'} );
2335 }
2336 return $self;
2337}
2338
dff75dee
TC
2339sub difference {
2340 my ($self, %opts) = @_;
2341
2342 defined $opts{mindist} or $opts{mindist} = 0;
2343
2344 defined $opts{other}
2345 or return $self->_set_error("No 'other' parameter supplied");
2346 defined $opts{other}{IMG}
2347 or return $self->_set_error("No image data in 'other' image");
2348
2349 $self->{IMG}
2350 or return $self->_set_error("No image data");
2351
2352 my $result = Imager->new;
2353 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
2354 $opts{mindist})
2355 or return $self->_set_error($self->_error_as_msg());
2356
2357 return $result;
2358}
2359
02d1d628
AMH
2360# destructive border - image is shrunk by one pixel all around
2361
2362sub border {
2363 my ($self,%opts)=@_;
2364 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2365 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2366}
2367
2368
2369# Get the width of an image
2370
2371sub getwidth {
2372 my $self = shift;
2373 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2374 return (i_img_info($self->{IMG}))[0];
2375}
2376
2377# Get the height of an image
2378
2379sub getheight {
2380 my $self = shift;
2381 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2382 return (i_img_info($self->{IMG}))[1];
2383}
2384
2385# Get number of channels in an image
2386
2387sub getchannels {
2388 my $self = shift;
2389 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2390 return i_img_getchannels($self->{IMG});
2391}
2392
2393# Get channel mask
2394
2395sub getmask {
2396 my $self = shift;
2397 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2398 return i_img_getmask($self->{IMG});
2399}
2400
2401# Set channel mask
2402
2403sub setmask {
2404 my $self = shift;
2405 my %opts = @_;
2406 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2407 i_img_setmask( $self->{IMG} , $opts{mask} );
2408}
2409
2410# Get number of colors in an image
2411
2412sub getcolorcount {
2413 my $self=shift;
9d540150 2414 my %opts=('maxcolors'=>2**30,@_);
02d1d628
AMH
2415 if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2416 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2417 return ($rc==-1? undef : $rc);
2418}
2419
2420# draw string to an image
2421
2422sub string {
2423 my $self = shift;
2424 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2425
2426 my %input=('x'=>0, 'y'=>0, @_);
2427 $input{string}||=$input{text};
2428
2429 unless(exists $input{string}) {
2430 $self->{ERRSTR}="missing required parameter 'string'";
2431 return;
2432 }
2433
2434 unless($input{font}) {
2435 $self->{ERRSTR}="missing required parameter 'font'";
2436 return;
2437 }
2438
faa9b3e7
TC
2439 unless ($input{font}->draw(image=>$self, %input)) {
2440 $self->{ERRSTR} = $self->_error_as_msg();
2441 return;
2442 }
02d1d628
AMH
2443
2444 return $self;
2445}
2446
02d1d628
AMH
2447# Shortcuts that can be exported
2448
2449sub newcolor { Imager::Color->new(@_); }
2450sub newfont { Imager::Font->new(@_); }
2451
2452*NC=*newcolour=*newcolor;
2453*NF=*newfont;
2454
2455*open=\&read;
2456*circle=\&arc;
2457
2458
2459#### Utility routines
2460
faa9b3e7
TC
2461sub errstr {
2462 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2463}
02d1d628 2464
10461f9a
TC
2465sub _set_error {
2466 my ($self, $msg) = @_;
2467
2468 if (ref $self) {
2469 $self->{ERRSTR} = $msg;
2470 }
2471 else {
2472 $ERRSTR = $msg;
2473 }
dff75dee 2474 return;
10461f9a
TC
2475}
2476
02d1d628
AMH
2477# Default guess for the type of an image from extension
2478
2479sub def_guess_type {
2480 my $name=lc(shift);
2481 my $ext;
2482 $ext=($name =~ m/\.([^\.]+)$/)[0];
2483 return 'tiff' if ($ext =~ m/^tiff?$/);
2484 return 'jpeg' if ($ext =~ m/^jpe?g$/);
2485 return 'pnm' if ($ext =~ m/^p[pgb]m$/);
2486 return 'png' if ($ext eq "png");
705fd961 2487 return 'bmp' if ($ext eq "bmp" || $ext eq "dib");
1ec86afa 2488 return 'tga' if ($ext eq "tga");
737a830c 2489 return 'rgb' if ($ext eq "rgb");
02d1d628 2490 return 'gif' if ($ext eq "gif");
10461f9a 2491 return 'raw' if ($ext eq "raw");
02d1d628
AMH
2492 return ();
2493}
2494
2495# get the minimum of a list
2496
2497sub min {
2498 my $mx=shift;
2499 for(@_) { if ($_<$mx) { $mx=$_; }}
2500 return $mx;
2501}
2502
2503# get the maximum of a list
2504
2505sub max {
2506 my $mx=shift;
2507 for(@_) { if ($_>$mx) { $mx=$_; }}
2508 return $mx;
2509}
2510
2511# string stuff for iptc headers
2512
2513sub clean {
2514 my($str)=$_[0];
2515 $str = substr($str,3);
2516 $str =~ s/[\n\r]//g;
2517 $str =~ s/\s+/ /g;
2518 $str =~ s/^\s//;
2519 $str =~ s/\s$//;
2520 return $str;
2521}
2522
2523# A little hack to parse iptc headers.
2524
2525sub parseiptc {
2526 my $self=shift;
2527 my(@sar,$item,@ar);
2528 my($caption,$photogr,$headln,$credit);
2529
2530 my $str=$self->{IPTCRAW};
2531
2532 #print $str;
2533
2534 @ar=split(/8BIM/,$str);
2535
2536 my $i=0;
2537 foreach (@ar) {
2538 if (/^\004\004/) {
2539 @sar=split(/\034\002/);
2540 foreach $item (@sar) {
cdd23610 2541 if ($item =~ m/^x/) {
02d1d628
AMH
2542 $caption=&clean($item);
2543 $i++;
2544 }
cdd23610 2545 if ($item =~ m/^P/) {
02d1d628
AMH
2546 $photogr=&clean($item);
2547 $i++;
2548 }
cdd23610 2549 if ($item =~ m/^i/) {
02d1d628
AMH
2550 $headln=&clean($item);
2551 $i++;
2552 }
cdd23610 2553 if ($item =~ m/^n/) {
02d1d628
AMH
2554 $credit=&clean($item);
2555 $i++;
2556 }
2557 }
2558 }
2559 }
2560 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2561}
2562
02d1d628
AMH
2563# Autoload methods go after =cut, and are processed by the autosplit program.
2564
25651;
2566__END__
2567# Below is the stub of documentation for your module. You better edit it!
2568
2569=head1 NAME
2570
2571Imager - Perl extension for Generating 24 bit Images
2572
2573=head1 SYNOPSIS
2574
0e418f1e
AMH
2575 # Thumbnail example
2576
2577 #!/usr/bin/perl -w
2578 use strict;
10461f9a 2579 use Imager;
02d1d628 2580
0e418f1e
AMH
2581 die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2582 my $file = shift;
2583
2584 my $format;
2585
2586 my $img = Imager->new();
2587 $img->open(file=>$file) or die $img->errstr();
2588
2589 $file =~ s/\.[^.]*$//;
2590
2591 # Create smaller version
2592 my $thumb = $img->scale(scalefactor=>.3);
2593
2594 # Autostretch individual channels
2595 $thumb->filter(type=>'autolevels');
2596
2597 # try to save in one of these formats
2598 SAVE:
2599
2600 for $format ( qw( png gif jpg tiff ppm ) ) {
2601 # Check if given format is supported
2602 if ($Imager::formats{$format}) {
2603 $file.="_low.$format";
2604 print "Storing image as: $file\n";
2605 $thumb->write(file=>$file) or
2606 die $thumb->errstr;
2607 last SAVE;
2608 }
2609 }
2610
2611
0e418f1e 2612
02d1d628
AMH
2613
2614=head1 DESCRIPTION
2615
0e418f1e
AMH
2616Imager is a module for creating and altering images. It can read and
2617write various image formats, draw primitive shapes like lines,and
2618polygons, blend multiple images together in various ways, scale, crop,
2619render text and more.
02d1d628 2620
5df0fac7
AMH
2621=head2 Overview of documentation
2622
2623=over
2624
2625=item Imager
2626
0e418f1e 2627This document - Synopsis Example, Table of Contents and Overview.
5df0fac7
AMH
2628
2629=item Imager::ImageTypes
2630
4b4f5319 2631Basics of constructing image objects with C<new()>:
5df0fac7 2632Direct type/virtual images, RGB(A)/paletted images, 8/16/double
f5fd108b 2633bits/channel, color maps, channel masks, image tags, color
6d0ed98a 2634quantization. Also discusses basic image information methods.
5df0fac7
AMH
2635
2636=item Imager::Files
2637
2638IO interaction, reading/writing images, format specific tags.
2639
2640=item Imager::Draw
2641
f5fd108b 2642Drawing Primitives, lines, boxes, circles, arcs, flood fill.
5df0fac7
AMH
2643
2644=item Imager::Color
2645
2646Color specification.
2647
daa45279 2648=item Imager::Fill
f5fd108b
AMH
2649
2650Fill pattern specification.
2651
5df0fac7
AMH
2652=item Imager::Font
2653
f5fd108b 2654General font rendering, bounding boxes and font metrics.
5df0fac7
AMH
2655
2656=item Imager::Transformations
2657
f5fd108b
AMH
2658Copying, scaling, cropping, flipping, blending, pasting, convert and
2659map.
5df0fac7
AMH
2660
2661=item Imager::Engines
2662
daa45279
AMH
2663Programmable transformations through C<transform()>, C<transform2()>
2664and C<matrix_transform()>.
5df0fac7
AMH
2665
2666=item Imager::Filters
2667
f5fd108b 2668Filters, sharpen, blur, noise, convolve etc. and filter plugins.
5df0fac7
AMH
2669
2670=item Imager::Expr
2671
2672Expressions for evaluation engine used by transform2().
2673
2674=item Imager::Matrix2d
2675
2676Helper class for affine transformations.
2677
2678=item Imager::Fountain
2679
2680Helper for making gradient profiles.
2681
2682=back
2683
2684
0e418f1e 2685
0e418f1e 2686=head2 Basic Overview
02d1d628 2687
55b287f5
AMH
2688An Image object is created with C<$img = Imager-E<gt>new()>.
2689Examples:
02d1d628 2690
55b287f5
AMH
2691 $img=Imager->new(); # create empty image
2692 $img->open(file=>'lena.png',type=>'png') or # read image from file
2693 die $img->errstr(); # give an explanation
2694 # if something failed
02d1d628
AMH
2695
2696or if you want to create an empty image:
2697
2698 $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2699
0e418f1e
AMH
2700This example creates a completely black image of width 400 and height
2701300 and 4 channels.
2702
55b287f5
AMH
2703When an operation fails which can be directly associated with an image
2704the error message is stored can be retrieved with
2705C<$img-E<gt>errstr()>.
2706
2707In cases where no image object is associated with an operation
2708C<$Imager::ERRSTR> is used to report errors not directly associated
2709with an image object.
2710
4b4f5319
AMH
2711The C<Imager-><gt>new> method is described in detail in the
2712Imager::ImageTypes manpage.
2713
f64132d2 2714=head1 SUPPORT
0e418f1e 2715
f64132d2
TC
2716You can ask for help, report bugs or express your undying love for
2717Imager on the Imager-devel mailing list.
02d1d628 2718
f64132d2
TC
2719To subscribe send a message with C<subscribe> in the body to:
2720
2721 imager-devel+request@molar.is
2722
2723or use the form at:
2724
2725 http://www.molar.is/en/lists/imager-devel/
55b287f5 2726 (annonymous is temporarily off due to spam)
f64132d2
TC
2727
2728where you can also find the mailing list archive.
10461f9a 2729
3ed96cd3
TC
2730If you're into IRC, you can typically find the developers in #Imager
2731on irc.rhizomatic.net. As with any IRC channel, the participants
2732could be occupied or asleep, so please be patient.
2733
02d1d628
AMH
2734=head1 BUGS
2735
0e418f1e 2736Bugs are listed individually for relevant pod pages.
02d1d628
AMH
2737
2738=head1 AUTHOR
2739
55b287f5 2740Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
f64132d2 2741(tony@imager.perl.org) See the README for a complete list.
02d1d628 2742
9495ee93 2743=head1 SEE ALSO
02d1d628 2744
55b287f5
AMH
2745perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
2746Imager::Color(3), Imager::Fill(3), Imager::Font(3),
2747Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
2748Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
009db950
AMH
2749
2750Affix::Infix2Postfix(3), Parse::RecDescent(3)
faa9b3e7 2751http://www.eecs.umich.edu/~addi/perl/Imager/
02d1d628
AMH
2752
2753=cut
55b287f5
AMH
2754
2755
2756
2757