temporary scaling test code, proper defaults for crop().
[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
893my @needseekcb = qw/tiff/;
894my %needseekcb = map { $_, $_ } @needseekcb;
895
896
897sub _get_reader_io {
898 my ($self, $input, $type) = @_;
899
900 if ($input->{fd}) {
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}) {
924 if ($needseekcb{$type} && !$input->{seekcb}) {
925 $self->_set_error("Format $type needs a seekcb parameter");
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
9d540150
TC
1014 if (!$input{'type'} and $input{file}) {
1015 $input{'type'}=$FORMATGUESS->($input{file});
895dbd34 1016 }
10461f9a
TC
1017 unless ($input{'type'}) {
1018 $self->_set_error('type parameter missing and not possible to guess from extension');
1019 return undef;
1020 }
9d540150 1021 if (!$formats{$input{'type'}}) {
895dbd34
AMH
1022 $self->{ERRSTR}='format not supported'; return undef;
1023 }
02d1d628 1024
10461f9a 1025 my %iolready=(jpeg=>1, png=>1, tiff=>1, pnm=>1, raw=>1, bmp=>1, tga=>1, rgb=>1, gif=>1);
02d1d628 1026
9d540150 1027 if ($iolready{$input{'type'}}) {
02d1d628 1028 # Setup data source
10461f9a
TC
1029 my ($IO, $fh) = $self->_get_reader_io(\%input, $input{'type'})
1030 or return;
02d1d628 1031
9d540150 1032 if ( $input{'type'} eq 'jpeg' ) {
02d1d628 1033 ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_wiol( $IO );
895dbd34
AMH
1034 if ( !defined($self->{IMG}) ) {
1035 $self->{ERRSTR}='unable to read jpeg image'; return undef;
1036 }
02d1d628
AMH
1037 $self->{DEBUG} && print "loading a jpeg file\n";
1038 return $self;
1039 }
1040
9d540150 1041 if ( $input{'type'} eq 'tiff' ) {
02d1d628 1042 $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
895dbd34 1043 if ( !defined($self->{IMG}) ) {
5bb828f1 1044 $self->{ERRSTR}=$self->_error_as_msg(); return undef;
895dbd34 1045 }
02d1d628
AMH
1046 $self->{DEBUG} && print "loading a tiff file\n";
1047 return $self;
1048 }
1049
9d540150 1050 if ( $input{'type'} eq 'pnm' ) {
02d1d628 1051 $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
895dbd34
AMH
1052 if ( !defined($self->{IMG}) ) {
1053 $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
1054 }
02d1d628
AMH
1055 $self->{DEBUG} && print "loading a pnm file\n";
1056 return $self;
1057 }
1058
9d540150 1059 if ( $input{'type'} eq 'png' ) {
790923a4
AMH
1060 $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1061 if ( !defined($self->{IMG}) ) {
1062 $self->{ERRSTR}='unable to read png image';
1063 return undef;
1064 }
1065 $self->{DEBUG} && print "loading a png file\n";
1066 }
1067
9d540150 1068 if ( $input{'type'} eq 'bmp' ) {
705fd961
TC
1069 $self->{IMG}=i_readbmp_wiol( $IO );
1070 if ( !defined($self->{IMG}) ) {
5bb828f1 1071 $self->{ERRSTR}=$self->_error_as_msg();
705fd961
TC
1072 return undef;
1073 }
1074 $self->{DEBUG} && print "loading a bmp file\n";
1075 }
1076
10461f9a
TC
1077 if ( $input{'type'} eq 'gif' ) {
1078 if ($input{colors} && !ref($input{colors})) {
1079 # must be a reference to a scalar that accepts the colour map
1080 $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1081 return undef;
1082 }
1083 if ($input{colors}) {
1084 my $colors;
1085 ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1086 if ($colors) {
1087 ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1088 }
1089 }
1090 else {
1091 $self->{IMG} =i_readgif_wiol( $IO );
1092 }
1093 if ( !defined($self->{IMG}) ) {
1094 $self->{ERRSTR}=$self->_error_as_msg();
1095 return undef;
1096 }
1097 $self->{DEBUG} && print "loading a gif file\n";
1098 }
1099
9d540150 1100 if ( $input{'type'} eq 'tga' ) {
1ec86afa
AMH
1101 $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1102 if ( !defined($self->{IMG}) ) {
1103 $self->{ERRSTR}=$self->_error_as_msg();
1ec86afa
AMH
1104 return undef;
1105 }
1106 $self->{DEBUG} && print "loading a tga file\n";
1107 }
1108
737a830c
AMH
1109 if ( $input{'type'} eq 'rgb' ) {
1110 $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1111 if ( !defined($self->{IMG}) ) {
1112 $self->{ERRSTR}=$self->_error_as_msg();
1113 return undef;
1114 }
1115 $self->{DEBUG} && print "loading a tga file\n";
1116 }
1117
1118
9d540150 1119 if ( $input{'type'} eq 'raw' ) {
895dbd34 1120 my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
02d1d628 1121
895dbd34
AMH
1122 if ( !($params{xsize} && $params{ysize}) ) {
1123 $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1124 return undef;
1125 }
02d1d628 1126
895dbd34
AMH
1127 $self->{IMG} = i_readraw_wiol( $IO,
1128 $params{xsize},
1129 $params{ysize},
1130 $params{datachannels},
1131 $params{storechannels},
1132 $params{interleave});
1133 if ( !defined($self->{IMG}) ) {
1134 $self->{ERRSTR}='unable to read raw image';
1135 return undef;
1136 }
1137 $self->{DEBUG} && print "loading a raw file\n";
1138 }
790923a4 1139
895dbd34 1140 } else {
02d1d628 1141
895dbd34 1142 # Old code for reference while changing the new stuff
02d1d628 1143
9d540150
TC
1144 if (!$input{'type'} and $input{file}) {
1145 $input{'type'}=$FORMATGUESS->($input{file});
895dbd34
AMH
1146 }
1147
9d540150 1148 if (!$input{'type'}) {
895dbd34
AMH
1149 $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef;
1150 }
02d1d628 1151
9d540150 1152 if (!$formats{$input{'type'}}) {
895dbd34 1153 $self->{ERRSTR}='format not supported';
a59ffd27
TC
1154 return undef;
1155 }
895dbd34 1156
10461f9a 1157 my ($fh, $fd);
895dbd34
AMH
1158 if ($input{file}) {
1159 $fh = new IO::File($input{file},"r");
1160 if (!defined $fh) {
1161 $self->{ERRSTR}='Could not open file';
1162 return undef;
a59ffd27 1163 }
895dbd34
AMH
1164 binmode($fh);
1165 $fd = $fh->fileno();
a59ffd27 1166 }
895dbd34
AMH
1167
1168 if ($input{fd}) {
1169 $fd=$input{fd};
1170 }
1171
9d540150 1172 if ( $input{'type'} eq 'gif' ) {
895dbd34
AMH
1173 my $colors;
1174 if ($input{colors} && !ref($input{colors})) {
1175 # must be a reference to a scalar that accepts the colour map
1176 $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1177 return undef;
a59ffd27 1178 }
895dbd34
AMH
1179 if (exists $input{data}) {
1180 if ($input{colors}) {
1181 ($self->{IMG}, $colors) = i_readgif_scalar($input{data});
1182 } else {
1183 $self->{IMG}=i_readgif_scalar($input{data});
1184 }
1185 } else {
1186 if ($input{colors}) {
1187 ($self->{IMG}, $colors) = i_readgif( $fd );
1188 } else {
1189 $self->{IMG} = i_readgif( $fd )
1190 }
a59ffd27 1191 }
895dbd34
AMH
1192 if ($colors) {
1193 # we may or may not change i_readgif to return blessed objects...
1194 ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1195 }
1196 if ( !defined($self->{IMG}) ) {
1197 $self->{ERRSTR}= 'reading GIF:'._error_as_msg();
1198 return undef;
1199 }
1200 $self->{DEBUG} && print "loading a gif file\n";
dd55acc8 1201 }
02d1d628
AMH
1202 }
1203 return $self;
02d1d628
AMH
1204}
1205
97c4effc
TC
1206sub _fix_gif_positions {
1207 my ($opts, $opt, $msg, @imgs) = @_;
1208
1209 my $positions = $opts->{'gif_positions'};
1210 my $index = 0;
1211 for my $pos (@$positions) {
1212 my ($x, $y) = @$pos;
1213 my $img = $imgs[$index++];
9d1c4956
TC
1214 $img->settag(name=>'gif_left', value=>$x);
1215 $img->settag(name=>'gif_top', value=>$y) if defined $y;
97c4effc
TC
1216 }
1217 $$msg .= "replaced with the gif_left and gif_top tags";
1218}
1219
1220my %obsolete_opts =
1221 (
1222 gif_each_palette=>'gif_local_map',
1223 interlace => 'gif_interlace',
1224 gif_delays => 'gif_delay',
1225 gif_positions => \&_fix_gif_positions,
1226 gif_loop_count => 'gif_loop',
1227 );
1228
1229sub _set_opts {
1230 my ($self, $opts, $prefix, @imgs) = @_;
1231
1232 for my $opt (keys %$opts) {
1233 my $tagname = $opt;
1234 if ($obsolete_opts{$opt}) {
1235 my $new = $obsolete_opts{$opt};
1236 my $msg = "Obsolete option $opt ";
1237 if (ref $new) {
1238 $new->($opts, $opt, \$msg, @imgs);
1239 }
1240 else {
1241 $msg .= "replaced with the $new tag ";
1242 $tagname = $new;
1243 }
1244 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1245 warn $msg if $warn_obsolete && $^W;
1246 }
1247 next unless $tagname =~ /^\Q$prefix/;
1248 my $value = $opts->{$opt};
1249 if (ref $value) {
1250 if (UNIVERSAL::isa($value, "Imager::Color")) {
1251 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1252 for my $img (@imgs) {
1253 $img->settag(name=>$tagname, value=>$tag);
1254 }
1255 }
1256 elsif (ref($value) eq 'ARRAY') {
1257 for my $i (0..$#$value) {
1258 my $val = $value->[$i];
1259 if (ref $val) {
1260 if (UNIVERSAL::isa($val, "Imager::Color")) {
1261 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1262 $i < @imgs and
1263 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1264 }
1265 else {
1266 $self->_set_error("Unknown reference type " . ref($value) .
1267 " supplied in array for $opt");
1268 return;
1269 }
1270 }
1271 else {
1272 $i < @imgs
1273 and $imgs[$i]->settag(name=>$tagname, value=>$val);
1274 }
1275 }
1276 }
1277 else {
1278 $self->_set_error("Unknown reference type " . ref($value) .
1279 " supplied for $opt");
1280 return;
1281 }
1282 }
1283 else {
1284 # set it as a tag for every image
1285 for my $img (@imgs) {
1286 $img->settag(name=>$tagname, value=>$value);
1287 }
1288 }
1289 }
1290
1291 return 1;
1292}
1293
02d1d628 1294# Write an image to file
02d1d628
AMH
1295sub write {
1296 my $self = shift;
febba01f
AMH
1297 my %input=(jpegquality=>75,
1298 gifquant=>'mc',
1299 lmdither=>6.0,
1300 lmfixed=>[],
1301 idstring=>"",
1302 compress=>1,
1303 wierdpack=>0,
4c2d6970 1304 fax_fine=>1, @_);
10461f9a 1305 my $rc;
02d1d628 1306
97c4effc
TC
1307 $self->_set_opts(\%input, "i_", $self)
1308 or return undef;
1309
10461f9a
TC
1310 my %iolready=( tiff=>1, raw=>1, png=>1, pnm=>1, bmp=>1, jpeg=>1, tga=>1,
1311 gif=>1 ); # this will be SO MUCH BETTER once they are all in there
02d1d628
AMH
1312
1313 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1314
9d540150
TC
1315 if (!$input{'type'} and $input{file}) {
1316 $input{'type'}=$FORMATGUESS->($input{file});
1317 }
1318 if (!$input{'type'}) {
1319 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1320 return undef;
1321 }
02d1d628 1322
9d540150 1323 if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
02d1d628 1324
10461f9a
TC
1325 my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1326 or return undef;
02d1d628 1327
10461f9a 1328 # this conditional is probably obsolete
9d540150 1329 if ($iolready{$input{'type'}}) {
02d1d628 1330
9d540150 1331 if ($input{'type'} eq 'tiff') {
97c4effc
TC
1332 $self->_set_opts(\%input, "tiff_", $self)
1333 or return undef;
1334 $self->_set_opts(\%input, "exif_", $self)
1335 or return undef;
1336
4c2d6970
TC
1337 if (defined $input{class} && $input{class} eq 'fax') {
1338 if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
d2dfdcc9
TC
1339 $self->{ERRSTR}='Could not write to buffer';
1340 return undef;
1341 }
04418ecc 1342 } else {
930c67c8
AMH
1343 if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1344 $self->{ERRSTR}='Could not write to buffer';
1345 return undef;
d2dfdcc9
TC
1346 }
1347 }
9d540150 1348 } elsif ( $input{'type'} eq 'pnm' ) {
97c4effc
TC
1349 $self->_set_opts(\%input, "pnm_", $self)
1350 or return undef;
04418ecc
AMH
1351 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1352 $self->{ERRSTR}='unable to write pnm image';
1353 return undef;
1354 }
1355 $self->{DEBUG} && print "writing a pnm file\n";
9d540150 1356 } elsif ( $input{'type'} eq 'raw' ) {
97c4effc
TC
1357 $self->_set_opts(\%input, "raw_", $self)
1358 or return undef;
ec9b9c3e 1359 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
04418ecc
AMH
1360 $self->{ERRSTR}='unable to write raw image';
1361 return undef;
1362 }
1363 $self->{DEBUG} && print "writing a raw file\n";
9d540150 1364 } elsif ( $input{'type'} eq 'png' ) {
97c4effc
TC
1365 $self->_set_opts(\%input, "png_", $self)
1366 or return undef;
ec9b9c3e
AMH
1367 if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1368 $self->{ERRSTR}='unable to write png image';
1369 return undef;
1370 }
1371 $self->{DEBUG} && print "writing a png file\n";
9d540150 1372 } elsif ( $input{'type'} eq 'jpeg' ) {
97c4effc
TC
1373 $self->_set_opts(\%input, "jpeg_", $self)
1374 or return undef;
1375 $self->_set_opts(\%input, "exif_", $self)
1376 or return undef;
cf692b64 1377 if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
f873cb01 1378 $self->{ERRSTR} = $self->_error_as_msg();
cf692b64
TC
1379 return undef;
1380 }
1381 $self->{DEBUG} && print "writing a jpeg file\n";
9d540150 1382 } elsif ( $input{'type'} eq 'bmp' ) {
97c4effc
TC
1383 $self->_set_opts(\%input, "bmp_", $self)
1384 or return undef;
705fd961
TC
1385 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1386 $self->{ERRSTR}='unable to write bmp image';
1387 return undef;
1388 }
1389 $self->{DEBUG} && print "writing a bmp file\n";
9d540150 1390 } elsif ( $input{'type'} eq 'tga' ) {
97c4effc
TC
1391 $self->_set_opts(\%input, "tga_", $self)
1392 or return undef;
febba01f
AMH
1393
1394 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1ec86afa 1395 $self->{ERRSTR}=$self->_error_as_msg();
1ec86afa
AMH
1396 return undef;
1397 }
1398 $self->{DEBUG} && print "writing a tga file\n";
10461f9a 1399 } elsif ( $input{'type'} eq 'gif' ) {
97c4effc
TC
1400 $self->_set_opts(\%input, "gif_", $self)
1401 or return undef;
10461f9a
TC
1402 # compatibility with the old interfaces
1403 if ($input{gifquant} eq 'lm') {
1404 $input{make_colors} = 'addi';
1405 $input{translate} = 'perturb';
1406 $input{perturb} = $input{lmdither};
1407 } elsif ($input{gifquant} eq 'gen') {
1408 # just pass options through
1409 } else {
1410 $input{make_colors} = 'webmap'; # ignored
1411 $input{translate} = 'giflib';
1412 }
1413 $rc = i_writegif_wiol($IO, \%input, $self->{IMG});
02d1d628
AMH
1414 }
1415
930c67c8
AMH
1416 if (exists $input{'data'}) {
1417 my $data = io_slurp($IO);
1418 if (!$data) {
1419 $self->{ERRSTR}='Could not slurp from buffer';
1420 return undef;
1421 }
1422 ${$input{data}} = $data;
1423 }
02d1d628 1424 return $self;
02d1d628 1425 }
10461f9a 1426
02d1d628
AMH
1427 return $self;
1428}
1429
1430sub write_multi {
1431 my ($class, $opts, @images) = @_;
1432
10461f9a
TC
1433 if (!$opts->{'type'} && $opts->{'file'}) {
1434 $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1435 }
1436 unless ($opts->{'type'}) {
1437 $class->_set_error('type parameter missing and not possible to guess from extension');
1438 return;
1439 }
1440 # translate to ImgRaw
1441 if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1442 $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1443 return 0;
1444 }
97c4effc
TC
1445 $class->_set_opts($opts, "i_", @images)
1446 or return;
10461f9a
TC
1447 my @work = map $_->{IMG}, @images;
1448 my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1449 or return undef;
9d540150 1450 if ($opts->{'type'} eq 'gif') {
97c4effc
TC
1451 $class->_set_opts($opts, "gif_", @images)
1452 or return;
ed88b092
TC
1453 my $gif_delays = $opts->{gif_delays};
1454 local $opts->{gif_delays} = $gif_delays;
10461f9a 1455 if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
ed88b092
TC
1456 # assume the caller wants the same delay for each frame
1457 $opts->{gif_delays} = [ ($gif_delays) x @images ];
1458 }
10461f9a
TC
1459 my $res = i_writegif_wiol($IO, $opts, @work);
1460 $res or $class->_set_error($class->_error_as_msg());
1461 return $res;
1462 }
1463 elsif ($opts->{'type'} eq 'tiff') {
97c4effc
TC
1464 $class->_set_opts($opts, "tiff_", @images)
1465 or return;
1466 $class->_set_opts($opts, "exif_", @images)
1467 or return;
10461f9a
TC
1468 my $res;
1469 $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1470 if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1471 $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
02d1d628
AMH
1472 }
1473 else {
10461f9a 1474 $res = i_writetiff_multi_wiol($IO, @work);
02d1d628 1475 }
10461f9a
TC
1476 $res or $class->_set_error($class->_error_as_msg());
1477 return $res;
02d1d628
AMH
1478 }
1479 else {
9d540150 1480 $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
02d1d628
AMH
1481 return 0;
1482 }
1483}
1484
faa9b3e7
TC
1485# read multiple images from a file
1486sub read_multi {
1487 my ($class, %opts) = @_;
1488
9d540150 1489 if ($opts{file} && !exists $opts{'type'}) {
faa9b3e7
TC
1490 # guess the type
1491 my $type = $FORMATGUESS->($opts{file});
9d540150 1492 $opts{'type'} = $type;
faa9b3e7 1493 }
9d540150 1494 unless ($opts{'type'}) {
faa9b3e7
TC
1495 $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1496 return;
1497 }
faa9b3e7 1498
10461f9a
TC
1499 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1500 or return;
9d540150 1501 if ($opts{'type'} eq 'gif') {
faa9b3e7 1502 my @imgs;
10461f9a
TC
1503 @imgs = i_readgif_multi_wiol($IO);
1504 if (@imgs) {
1505 return map {
1506 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1507 } @imgs;
faa9b3e7
TC
1508 }
1509 else {
10461f9a
TC
1510 $ERRSTR = _error_as_msg();
1511 return;
faa9b3e7 1512 }
10461f9a
TC
1513 }
1514 elsif ($opts{'type'} eq 'tiff') {
1515 my @imgs = i_readtiff_multi_wiol($IO, -1);
faa9b3e7
TC
1516 if (@imgs) {
1517 return map {
1518 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1519 } @imgs;
1520 }
1521 else {
1522 $ERRSTR = _error_as_msg();
1523 return;
1524 }
1525 }
1526
9d540150 1527 $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
faa9b3e7
TC
1528 return;
1529}
1530
02d1d628
AMH
1531# Destroy an Imager object
1532
1533sub DESTROY {
1534 my $self=shift;
1535 # delete $instances{$self};
1536 if (defined($self->{IMG})) {
faa9b3e7
TC
1537 # the following is now handled by the XS DESTROY method for
1538 # Imager::ImgRaw object
1539 # Re-enabling this will break virtual images
1540 # tested for in t/t020masked.t
1541 # i_img_destroy($self->{IMG});
02d1d628
AMH
1542 undef($self->{IMG});
1543 } else {
1544# print "Destroy Called on an empty image!\n"; # why did I put this here??
1545 }
1546}
1547
1548# Perform an inplace filter of an image
1549# that is the image will be overwritten with the data
1550
1551sub filter {
1552 my $self=shift;
1553 my %input=@_;
1554 my %hsh;
1555 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1556
9d540150 1557 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
02d1d628 1558
9d540150 1559 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
02d1d628
AMH
1560 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1561 }
1562
9d540150
TC
1563 if ($filters{$input{'type'}}{names}) {
1564 my $names = $filters{$input{'type'}}{names};
6607600c
TC
1565 for my $name (keys %$names) {
1566 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1567 $input{$name} = $names->{$name}{$input{$name}};
1568 }
1569 }
1570 }
9d540150
TC
1571 if (defined($filters{$input{'type'}}{defaults})) {
1572 %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
02d1d628
AMH
1573 } else {
1574 %hsh=('image',$self->{IMG},%input);
1575 }
1576
9d540150 1577 my @cs=@{$filters{$input{'type'}}{callseq}};
02d1d628
AMH
1578
1579 for(@cs) {
1580 if (!defined($hsh{$_})) {
9d540150 1581 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
02d1d628
AMH
1582 }
1583 }
1584
9d540150 1585 &{$filters{$input{'type'}}{callsub}}(%hsh);
02d1d628
AMH
1586
1587 my @b=keys %hsh;
1588
1589 $self->{DEBUG} && print "callseq is: @cs\n";
1590 $self->{DEBUG} && print "matching callseq is: @b\n";
1591
1592 return $self;
1593}
1594
1595# Scale an image to requested size and return the scaled version
1596
1597sub scale {
1598 my $self=shift;
9d540150 1599 my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
02d1d628
AMH
1600 my $img = Imager->new();
1601 my $tmp = Imager->new();
1602
1603 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1604
9d540150 1605 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
02d1d628 1606 my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
9d540150
TC
1607 if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1608 if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
02d1d628
AMH
1609 } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1610 elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1611
1612 if ($opts{qtype} eq 'normal') {
1613 $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1614 if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1615 $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1616 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1617 return $img;
1618 }
1619 if ($opts{'qtype'} eq 'preview') {
1620 $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
1621 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1622 return $img;
1623 }
1624 $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1625}
1626
1627# Scales only along the X axis
1628
1629sub scaleX {
1630 my $self=shift;
1631 my %opts=(scalefactor=>0.5,@_);
1632
1633 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1634
1635 my $img = Imager->new();
1636
1637 if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1638
1639 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1640 $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1641
1642 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1643 return $img;
1644}
1645
1646# Scales only along the Y axis
1647
1648sub scaleY {
1649 my $self=shift;
1650 my %opts=(scalefactor=>0.5,@_);
1651
1652 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1653
1654 my $img = Imager->new();
1655
1656 if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1657
1658 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1659 $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1660
1661 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1662 return $img;
1663}
1664
1665
1666# Transform returns a spatial transformation of the input image
1667# this moves pixels to a new location in the returned image.
1668# NOTE - should make a utility function to check transforms for
1669# stack overruns
1670
1671sub transform {
1672 my $self=shift;
1673 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1674 my %opts=@_;
1675 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1676
1677# print Dumper(\%opts);
1678# xopcopdes
1679
1680 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1681 if (!$I2P) {
1682 eval ("use Affix::Infix2Postfix;");
1683 print $@;
1684 if ( $@ ) {
1685 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
1686 return undef;
1687 }
1688 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1689 {op=>'-',trans=>'Sub'},
1690 {op=>'*',trans=>'Mult'},
1691 {op=>'/',trans=>'Div'},
9d540150 1692 {op=>'-','type'=>'unary',trans=>'u-'},
02d1d628 1693 {op=>'**'},
9d540150 1694 {op=>'func','type'=>'unary'}],
02d1d628
AMH
1695 'grouping'=>[qw( \( \) )],
1696 'func'=>[qw( sin cos )],
1697 'vars'=>[qw( x y )]
1698 );
1699 }
1700
1701 @xt=$I2P->translate($opts{'xexpr'});
1702 @yt=$I2P->translate($opts{'yexpr'});
1703
1704 $numre=$I2P->{'numre'};
1705 @pt=(0,0);
1706
1707 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1708 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1709 @{$opts{'parm'}}=@pt;
1710 }
1711
1712# print Dumper(\%opts);
1713
1714 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1715 $self->{ERRSTR}='transform: no xopcodes given.';
1716 return undef;
1717 }
1718
1719 @op=@{$opts{'xopcodes'}};
1720 for $iop (@op) {
1721 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1722 $self->{ERRSTR}="transform: illegal opcode '$_'.";
1723 return undef;
1724 }
1725 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1726 }
1727
1728
1729# yopcopdes
1730
1731 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1732 $self->{ERRSTR}='transform: no yopcodes given.';
1733 return undef;
1734 }
1735
1736 @op=@{$opts{'yopcodes'}};
1737 for $iop (@op) {
1738 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1739 $self->{ERRSTR}="transform: illegal opcode '$_'.";
1740 return undef;
1741 }
1742 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1743 }
1744
1745#parameters
1746
1747 if ( !exists $opts{'parm'}) {
1748 $self->{ERRSTR}='transform: no parameter arg given.';
1749 return undef;
1750 }
1751
1752# print Dumper(\@ropx);
1753# print Dumper(\@ropy);
1754# print Dumper(\@ropy);
1755
1756 my $img = Imager->new();
1757 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1758 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1759 return $img;
1760}
1761
1762
bf94b653
TC
1763sub transform2 {
1764 my ($opts, @imgs) = @_;
1765
1766 require "Imager/Expr.pm";
1767
1768 $opts->{variables} = [ qw(x y) ];
1769 my ($width, $height) = @{$opts}{qw(width height)};
1770 if (@imgs) {
1771 $width ||= $imgs[0]->getwidth();
1772 $height ||= $imgs[0]->getheight();
1773 my $img_num = 1;
1774 for my $img (@imgs) {
1775 $opts->{constants}{"w$img_num"} = $img->getwidth();
1776 $opts->{constants}{"h$img_num"} = $img->getheight();
1777 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1778 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1779 ++$img_num;
02d1d628 1780 }
02d1d628 1781 }
bf94b653
TC
1782 if ($width) {
1783 $opts->{constants}{w} = $width;
1784 $opts->{constants}{cx} = $width/2;
1785 }
1786 else {
1787 $Imager::ERRSTR = "No width supplied";
1788 return;
1789 }
1790 if ($height) {
1791 $opts->{constants}{h} = $height;
1792 $opts->{constants}{cy} = $height/2;
1793 }
1794 else {
1795 $Imager::ERRSTR = "No height supplied";
1796 return;
1797 }
1798 my $code = Imager::Expr->new($opts);
1799 if (!$code) {
1800 $Imager::ERRSTR = Imager::Expr::error();
1801 return;
1802 }
9982a307 1803
bf94b653
TC
1804 my $img = Imager->new();
1805 $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, $code->code(),
1806 $code->nregs(), $code->cregs(),
1807 [ map { $_->{IMG} } @imgs ]);
1808 if (!defined $img->{IMG}) {
1809 $Imager::ERRSTR = Imager->_error_as_msg();
1810 return;
1811 }
9982a307 1812
bf94b653 1813 return $img;
02d1d628
AMH
1814}
1815
02d1d628
AMH
1816sub rubthrough {
1817 my $self=shift;
1818 my %opts=(tx=>0,ty=>0,@_);
1819
1820 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1821 unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1822
faa9b3e7
TC
1823 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx},$opts{ty})) {
1824 $self->{ERRSTR} = $self->_error_as_msg();
1825 return undef;
1826 }
02d1d628
AMH
1827 return $self;
1828}
1829
1830
142c26ff
AMH
1831sub flip {
1832 my $self = shift;
1833 my %opts = @_;
9191e525 1834 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH
1835 my $dir;
1836 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1837 $dir = $xlate{$opts{'dir'}};
1838 return $self if i_flipxy($self->{IMG}, $dir);
1839 return ();
1840}
1841
faa9b3e7
TC
1842sub rotate {
1843 my $self = shift;
1844 my %opts = @_;
1845 if (defined $opts{right}) {
1846 my $degrees = $opts{right};
1847 if ($degrees < 0) {
1848 $degrees += 360 * int(((-$degrees)+360)/360);
1849 }
1850 $degrees = $degrees % 360;
1851 if ($degrees == 0) {
1852 return $self->copy();
1853 }
1854 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1855 my $result = Imager->new();
1856 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1857 return $result;
1858 }
1859 else {
1860 $self->{ERRSTR} = $self->_error_as_msg();
1861 return undef;
1862 }
1863 }
1864 else {
1865 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1866 return undef;
1867 }
1868 }
1869 elsif (defined $opts{radians} || defined $opts{degrees}) {
1870 my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1871
1872 my $result = Imager->new;
1873 if ($result->{IMG} = i_rotate_exact($self->{IMG}, $amount)) {
1874 return $result;
1875 }
1876 else {
1877 $self->{ERRSTR} = $self->_error_as_msg();
1878 return undef;
1879 }
1880 }
1881 else {
1882 $self->{ERRSTR} = "Only the 'right' parameter is available";
1883 return undef;
1884 }
1885}
1886
1887sub matrix_transform {
1888 my $self = shift;
1889 my %opts = @_;
1890
1891 if ($opts{matrix}) {
1892 my $xsize = $opts{xsize} || $self->getwidth;
1893 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 1894
faa9b3e7
TC
1895 my $result = Imager->new;
1896 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1897 $opts{matrix})
1898 or return undef;
1899
1900 return $result;
1901 }
1902 else {
1903 $self->{ERRSTR} = "matrix parameter required";
1904 return undef;
1905 }
1906}
1907
1908# blame Leolo :)
1909*yatf = \&matrix_transform;
02d1d628
AMH
1910
1911# These two are supported for legacy code only
1912
1913sub i_color_new {
faa9b3e7 1914 return Imager::Color->new(@_);
02d1d628
AMH
1915}
1916
1917sub i_color_set {
faa9b3e7 1918 return Imager::Color::set(@_);
02d1d628
AMH
1919}
1920
02d1d628 1921# Draws a box between the specified corner points.
02d1d628
AMH
1922sub box {
1923 my $self=shift;
1924 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1925 my $dflcl=i_color_new(255,255,255,255);
1926 my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1927
1928 if (exists $opts{'box'}) {
1929 $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1930 $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1931 $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1932 $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1933 }
1934
f1ac5027 1935 if ($opts{filled}) {
3a9a4241
TC
1936 my $color = _color($opts{'color'});
1937 unless ($color) {
1938 $self->{ERRSTR} = $Imager::ERRSTR;
1939 return;
1940 }
f1ac5027 1941 i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
3a9a4241 1942 $opts{ymax}, $color);
f1ac5027
TC
1943 }
1944 elsif ($opts{fill}) {
1945 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1946 # assume it's a hash ref
1947 require 'Imager/Fill.pm';
141a6114
TC
1948 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1949 $self->{ERRSTR} = $Imager::ERRSTR;
1950 return undef;
1951 }
f1ac5027
TC
1952 }
1953 i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1954 $opts{ymax},$opts{fill}{fill});
1955 }
cdd23610 1956 else {
3a9a4241
TC
1957 my $color = _color($opts{'color'});
1958 unless ($color) {
cdd23610
AMH
1959 $self->{ERRSTR} = $Imager::ERRSTR;
1960 return;
3a9a4241
TC
1961 }
1962 i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
1963 $color);
f1ac5027 1964 }
02d1d628
AMH
1965 return $self;
1966}
1967
1968# Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
1969
1970sub arc {
1971 my $self=shift;
1972 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1973 my $dflcl=i_color_new(255,255,255,255);
1974 my %opts=(color=>$dflcl,
1975 'r'=>min($self->getwidth(),$self->getheight())/3,
1976 'x'=>$self->getwidth()/2,
1977 'y'=>$self->getheight()/2,
1978 'd1'=>0, 'd2'=>361, @_);
f1ac5027
TC
1979 if ($opts{fill}) {
1980 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1981 # assume it's a hash ref
1982 require 'Imager/Fill.pm';
569795e8
TC
1983 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1984 $self->{ERRSTR} = $Imager::ERRSTR;
1985 return;
1986 }
f1ac5027
TC
1987 }
1988 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
1989 $opts{'d2'}, $opts{fill}{fill});
1990 }
1991 else {
3a9a4241
TC
1992 my $color = _color($opts{'color'});
1993 unless ($color) {
1994 $self->{ERRSTR} = $Imager::ERRSTR;
1995 return;
1996 }
0d321238
TC
1997 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
1998 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
3a9a4241 1999 $color);
0d321238
TC
2000 }
2001 else {
3a9a4241
TC
2002 if ($opts{'d1'} <= $opts{'d2'}) {
2003 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2004 $opts{'d1'}, $opts{'d2'}, $color);
2005 }
2006 else {
2007 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2008 $opts{'d1'}, 361, $color);
2009 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2010 0, $opts{'d2'}, $color);
2011 }
0d321238 2012 }
f1ac5027
TC
2013 }
2014
02d1d628
AMH
2015 return $self;
2016}
2017
aa833c97
AMH
2018# Draws a line from one point to the other
2019# the endpoint is set if the endp parameter is set which it is by default.
2020# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH
2021
2022sub line {
2023 my $self=shift;
2024 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH
2025 my %opts=(color=>$dflcl,
2026 endp => 1,
2027 @_);
02d1d628
AMH
2028 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2029
2030 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2031 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2032
3a9a4241 2033 my $color = _color($opts{'color'});
aa833c97
AMH
2034 unless ($color) {
2035 $self->{ERRSTR} = $Imager::ERRSTR;
2036 return;
3a9a4241 2037 }
aa833c97 2038
3a9a4241 2039 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 2040 if ($opts{antialias}) {
aa833c97 2041 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 2042 $color, $opts{endp});
02d1d628 2043 } else {
aa833c97
AMH
2044 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2045 $color, $opts{endp});
02d1d628
AMH
2046 }
2047 return $self;
2048}
2049
2050# Draws a line between an ordered set of points - It more or less just transforms this
2051# into a list of lines.
2052
2053sub polyline {
2054 my $self=shift;
2055 my ($pt,$ls,@points);
2056 my $dflcl=i_color_new(0,0,0,0);
2057 my %opts=(color=>$dflcl,@_);
2058
2059 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2060
2061 if (exists($opts{points})) { @points=@{$opts{points}}; }
2062 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2063 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2064 }
2065
2066# print Dumper(\@points);
2067
3a9a4241
TC
2068 my $color = _color($opts{'color'});
2069 unless ($color) {
2070 $self->{ERRSTR} = $Imager::ERRSTR;
2071 return;
2072 }
2073 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH
2074 if ($opts{antialias}) {
2075 for $pt(@points) {
3a9a4241 2076 if (defined($ls)) {
b437ce0a 2077 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 2078 }
02d1d628
AMH
2079 $ls=$pt;
2080 }
2081 } else {
2082 for $pt(@points) {
3a9a4241 2083 if (defined($ls)) {
aa833c97 2084 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 2085 }
02d1d628
AMH
2086 $ls=$pt;
2087 }
2088 }
2089 return $self;
2090}
2091
d0e7bfee
AMH
2092sub polygon {
2093 my $self = shift;
2094 my ($pt,$ls,@points);
2095 my $dflcl = i_color_new(0,0,0,0);
2096 my %opts = (color=>$dflcl, @_);
2097
2098 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2099
2100 if (exists($opts{points})) {
2101 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2102 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2103 }
2104
2105 if (!exists $opts{'x'} or !exists $opts{'y'}) {
2106 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2107 }
2108
43c5dacb
TC
2109 if ($opts{'fill'}) {
2110 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2111 # assume it's a hash ref
2112 require 'Imager/Fill.pm';
2113 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2114 $self->{ERRSTR} = $Imager::ERRSTR;
2115 return undef;
2116 }
2117 }
2118 i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2119 $opts{'fill'}{'fill'});
2120 }
2121 else {
3a9a4241
TC
2122 my $color = _color($opts{'color'});
2123 unless ($color) {
2124 $self->{ERRSTR} = $Imager::ERRSTR;
2125 return;
2126 }
2127 i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
43c5dacb
TC
2128 }
2129
d0e7bfee
AMH
2130 return $self;
2131}
2132
2133
2134# this the multipoint bezier curve
02d1d628
AMH
2135# this is here more for testing that actual usage since
2136# this is not a good algorithm. Usually the curve would be
2137# broken into smaller segments and each done individually.
2138
2139sub polybezier {
2140 my $self=shift;
2141 my ($pt,$ls,@points);
2142 my $dflcl=i_color_new(0,0,0,0);
2143 my %opts=(color=>$dflcl,@_);
2144
2145 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2146
2147 if (exists $opts{points}) {
2148 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2149 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2150 }
2151
2152 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2153 $self->{ERRSTR}='Missing or invalid points.';
2154 return;
2155 }
2156
3a9a4241
TC
2157 my $color = _color($opts{'color'});
2158 unless ($color) {
2159 $self->{ERRSTR} = $Imager::ERRSTR;
2160 return;
2161 }
2162 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH
2163 return $self;
2164}
2165
cc6483e0
TC
2166sub flood_fill {
2167 my $self = shift;
2168 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH
2169 my $rc;
2170
9d540150 2171 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC
2172 $self->{ERRSTR} = "missing seed x and y parameters";
2173 return undef;
2174 }
07d70837 2175
cc6483e0
TC
2176 if ($opts{fill}) {
2177 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2178 # assume it's a hash ref
2179 require 'Imager/Fill.pm';
569795e8
TC
2180 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2181 $self->{ERRSTR} = $Imager::ERRSTR;
2182 return;
2183 }
cc6483e0 2184 }
a321d497 2185 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
cc6483e0
TC
2186 }
2187 else {
3a9a4241 2188 my $color = _color($opts{'color'});
aa833c97
AMH
2189 unless ($color) {
2190 $self->{ERRSTR} = $Imager::ERRSTR;
2191 return;
3a9a4241 2192 }
a321d497 2193 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
cc6483e0 2194 }
aa833c97 2195 if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
cc6483e0
TC
2196}
2197
591b5954
TC
2198sub setpixel {
2199 my $self = shift;
2200
2201 my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2202
2203 unless (exists $opts{'x'} && exists $opts{'y'}) {
2204 $self->{ERRSTR} = 'missing x and y parameters';
2205 return undef;
2206 }
2207
2208 my $x = $opts{'x'};
2209 my $y = $opts{'y'};
2210 my $color = _color($opts{color})
2211 or return undef;
2212 if (ref $x && ref $y) {
2213 unless (@$x == @$y) {
9650c424 2214 $self->{ERRSTR} = 'length of x and y mismatch';
591b5954
TC
2215 return undef;
2216 }
2217 if ($color->isa('Imager::Color')) {
2218 for my $i (0..$#{$opts{'x'}}) {
2219 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2220 }
2221 }
2222 else {
2223 for my $i (0..$#{$opts{'x'}}) {
2224 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2225 }
2226 }
2227 }
2228 else {
2229 if ($color->isa('Imager::Color')) {
2230 i_ppix($self->{IMG}, $x, $y, $color);
2231 }
2232 else {
2233 i_ppixf($self->{IMG}, $x, $y, $color);
2234 }
2235 }
2236
2237 $self;
2238}
2239
2240sub getpixel {
2241 my $self = shift;
2242
a9fa203f 2243 my %opts = ( "type"=>'8bit', @_);
591b5954
TC
2244
2245 unless (exists $opts{'x'} && exists $opts{'y'}) {
2246 $self->{ERRSTR} = 'missing x and y parameters';
2247 return undef;
2248 }
2249
2250 my $x = $opts{'x'};
2251 my $y = $opts{'y'};
2252 if (ref $x && ref $y) {
2253 unless (@$x == @$y) {
2254 $self->{ERRSTR} = 'length of x and y mismatch';
2255 return undef;
2256 }
2257 my @result;
a9fa203f 2258 if ($opts{"type"} eq '8bit') {
591b5954
TC
2259 for my $i (0..$#{$opts{'x'}}) {
2260 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2261 }
2262 }
2263 else {
2264 for my $i (0..$#{$opts{'x'}}) {
2265 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2266 }
2267 }
2268 return wantarray ? @result : \@result;
2269 }
2270 else {
a9fa203f 2271 if ($opts{"type"} eq '8bit') {
591b5954
TC
2272 return i_get_pixel($self->{IMG}, $x, $y);
2273 }
2274 else {
2275 return i_gpixf($self->{IMG}, $x, $y);
2276 }
2277 }
2278
2279 $self;
2280}
2281
f5991c03
TC
2282# make an identity matrix of the given size
2283sub _identity {
2284 my ($size) = @_;
2285
2286 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2287 for my $c (0 .. ($size-1)) {
2288 $matrix->[$c][$c] = 1;
2289 }
2290 return $matrix;
2291}
2292
2293# general function to convert an image
2294sub convert {
2295 my ($self, %opts) = @_;
2296 my $matrix;
2297
2298 # the user can either specify a matrix or preset
2299 # the matrix overrides the preset
2300 if (!exists($opts{matrix})) {
2301 unless (exists($opts{preset})) {
2302 $self->{ERRSTR} = "convert() needs a matrix or preset";
2303 return;
2304 }
2305 else {
2306 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2307 # convert to greyscale, keeping the alpha channel if any
2308 if ($self->getchannels == 3) {
2309 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2310 }
2311 elsif ($self->getchannels == 4) {
2312 # preserve the alpha channel
2313 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2314 [ 0, 0, 0, 1 ] ];
2315 }
2316 else {
2317 # an identity
2318 $matrix = _identity($self->getchannels);
2319 }
2320 }
2321 elsif ($opts{preset} eq 'noalpha') {
2322 # strip the alpha channel
2323 if ($self->getchannels == 2 or $self->getchannels == 4) {
2324 $matrix = _identity($self->getchannels);
2325 pop(@$matrix); # lose the alpha entry
2326 }
2327 else {
2328 $matrix = _identity($self->getchannels);
2329 }
2330 }
2331 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2332 # extract channel 0
2333 $matrix = [ [ 1 ] ];
2334 }
2335 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2336 $matrix = [ [ 0, 1 ] ];
2337 }
2338 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2339 $matrix = [ [ 0, 0, 1 ] ];
2340 }
2341 elsif ($opts{preset} eq 'alpha') {
2342 if ($self->getchannels == 2 or $self->getchannels == 4) {
2343 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2344 }
2345 else {
2346 # the alpha is just 1 <shrug>
2347 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2348 }
2349 }
2350 elsif ($opts{preset} eq 'rgb') {
2351 if ($self->getchannels == 1) {
2352 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2353 }
2354 elsif ($self->getchannels == 2) {
2355 # preserve the alpha channel
2356 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2357 }
2358 else {
2359 $matrix = _identity($self->getchannels);
2360 }
2361 }
2362 elsif ($opts{preset} eq 'addalpha') {
2363 if ($self->getchannels == 1) {
2364 $matrix = _identity(2);
2365 }
2366 elsif ($self->getchannels == 3) {
2367 $matrix = _identity(4);
2368 }
2369 else {
2370 $matrix = _identity($self->getchannels);
2371 }
2372 }
2373 else {
2374 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2375 return undef;
2376 }
2377 }
2378 }
2379 else {
2380 $matrix = $opts{matrix};
2381 }
2382
2383 my $new = Imager->new();
2384 $new->{IMG} = i_img_new();
2385 unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2386 # most likely a bad matrix
2387 $self->{ERRSTR} = _error_as_msg();
2388 return undef;
2389 }
2390 return $new;
2391}
40eba1ea
AMH
2392
2393
40eba1ea 2394# general function to map an image through lookup tables
9495ee93 2395
40eba1ea
AMH
2396sub map {
2397 my ($self, %opts) = @_;
9495ee93 2398 my @chlist = qw( red green blue alpha );
40eba1ea
AMH
2399
2400 if (!exists($opts{'maps'})) {
2401 # make maps from channel maps
2402 my $chnum;
2403 for $chnum (0..$#chlist) {
9495ee93
AMH
2404 if (exists $opts{$chlist[$chnum]}) {
2405 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2406 } elsif (exists $opts{'all'}) {
2407 $opts{'maps'}[$chnum] = $opts{'all'};
2408 }
40eba1ea
AMH
2409 }
2410 }
2411 if ($opts{'maps'} and $self->{IMG}) {
2412 i_map($self->{IMG}, $opts{'maps'} );
2413 }
2414 return $self;
2415}
2416
dff75dee
TC
2417sub difference {
2418 my ($self, %opts) = @_;
2419
2420 defined $opts{mindist} or $opts{mindist} = 0;
2421
2422 defined $opts{other}
2423 or return $self->_set_error("No 'other' parameter supplied");
2424 defined $opts{other}{IMG}
2425 or return $self->_set_error("No image data in 'other' image");
2426
2427 $self->{IMG}
2428 or return $self->_set_error("No image data");
2429
2430 my $result = Imager->new;
2431 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
2432 $opts{mindist})
2433 or return $self->_set_error($self->_error_as_msg());
2434
2435 return $result;
2436}
2437
02d1d628
AMH
2438# destructive border - image is shrunk by one pixel all around
2439
2440sub border {
2441 my ($self,%opts)=@_;
2442 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2443 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2444}
2445
2446
2447# Get the width of an image
2448
2449sub getwidth {
2450 my $self = shift;
2451 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2452 return (i_img_info($self->{IMG}))[0];
2453}
2454
2455# Get the height of an image
2456
2457sub getheight {
2458 my $self = shift;
2459 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2460 return (i_img_info($self->{IMG}))[1];
2461}
2462
2463# Get number of channels in an image
2464
2465sub getchannels {
2466 my $self = shift;
2467 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2468 return i_img_getchannels($self->{IMG});
2469}
2470
2471# Get channel mask
2472
2473sub getmask {
2474 my $self = shift;
2475 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2476 return i_img_getmask($self->{IMG});
2477}
2478
2479# Set channel mask
2480
2481sub setmask {
2482 my $self = shift;
2483 my %opts = @_;
2484 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2485 i_img_setmask( $self->{IMG} , $opts{mask} );
2486}
2487
2488# Get number of colors in an image
2489
2490sub getcolorcount {
2491 my $self=shift;
9d540150 2492 my %opts=('maxcolors'=>2**30,@_);
02d1d628
AMH
2493 if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2494 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2495 return ($rc==-1? undef : $rc);
2496}
2497
2498# draw string to an image
2499
2500sub string {
2501 my $self = shift;
2502 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2503
2504 my %input=('x'=>0, 'y'=>0, @_);
2505 $input{string}||=$input{text};
2506
2507 unless(exists $input{string}) {
2508 $self->{ERRSTR}="missing required parameter 'string'";
2509 return;
2510 }
2511
2512 unless($input{font}) {
2513 $self->{ERRSTR}="missing required parameter 'font'";
2514 return;
2515 }
2516
faa9b3e7
TC
2517 unless ($input{font}->draw(image=>$self, %input)) {
2518 $self->{ERRSTR} = $self->_error_as_msg();
2519 return;
2520 }
02d1d628
AMH
2521
2522 return $self;
2523}
2524
02d1d628
AMH
2525# Shortcuts that can be exported
2526
2527sub newcolor { Imager::Color->new(@_); }
2528sub newfont { Imager::Font->new(@_); }
2529
2530*NC=*newcolour=*newcolor;
2531*NF=*newfont;
2532
2533*open=\&read;
2534*circle=\&arc;
2535
2536
2537#### Utility routines
2538
faa9b3e7
TC
2539sub errstr {
2540 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2541}
02d1d628 2542
10461f9a
TC
2543sub _set_error {
2544 my ($self, $msg) = @_;
2545
2546 if (ref $self) {
2547 $self->{ERRSTR} = $msg;
2548 }
2549 else {
2550 $ERRSTR = $msg;
2551 }
dff75dee 2552 return;
10461f9a
TC
2553}
2554
02d1d628
AMH
2555# Default guess for the type of an image from extension
2556
2557sub def_guess_type {
2558 my $name=lc(shift);
2559 my $ext;
2560 $ext=($name =~ m/\.([^\.]+)$/)[0];
2561 return 'tiff' if ($ext =~ m/^tiff?$/);
2562 return 'jpeg' if ($ext =~ m/^jpe?g$/);
2563 return 'pnm' if ($ext =~ m/^p[pgb]m$/);
2564 return 'png' if ($ext eq "png");
705fd961 2565 return 'bmp' if ($ext eq "bmp" || $ext eq "dib");
1ec86afa 2566 return 'tga' if ($ext eq "tga");
737a830c 2567 return 'rgb' if ($ext eq "rgb");
02d1d628 2568 return 'gif' if ($ext eq "gif");
10461f9a 2569 return 'raw' if ($ext eq "raw");
02d1d628
AMH
2570 return ();
2571}
2572
2573# get the minimum of a list
2574
2575sub min {
2576 my $mx=shift;
2577 for(@_) { if ($_<$mx) { $mx=$_; }}
2578 return $mx;
2579}
2580
2581# get the maximum of a list
2582
2583sub max {
2584 my $mx=shift;
2585 for(@_) { if ($_>$mx) { $mx=$_; }}
2586 return $mx;
2587}
2588
2589# string stuff for iptc headers
2590
2591sub clean {
2592 my($str)=$_[0];
2593 $str = substr($str,3);
2594 $str =~ s/[\n\r]//g;
2595 $str =~ s/\s+/ /g;
2596 $str =~ s/^\s//;
2597 $str =~ s/\s$//;
2598 return $str;
2599}
2600
2601# A little hack to parse iptc headers.
2602
2603sub parseiptc {
2604 my $self=shift;
2605 my(@sar,$item,@ar);
2606 my($caption,$photogr,$headln,$credit);
2607
2608 my $str=$self->{IPTCRAW};
2609
2610 #print $str;
2611
2612 @ar=split(/8BIM/,$str);
2613
2614 my $i=0;
2615 foreach (@ar) {
2616 if (/^\004\004/) {
2617 @sar=split(/\034\002/);
2618 foreach $item (@sar) {
cdd23610 2619 if ($item =~ m/^x/) {
02d1d628
AMH
2620 $caption=&clean($item);
2621 $i++;
2622 }
cdd23610 2623 if ($item =~ m/^P/) {
02d1d628
AMH
2624 $photogr=&clean($item);
2625 $i++;
2626 }
cdd23610 2627 if ($item =~ m/^i/) {
02d1d628
AMH
2628 $headln=&clean($item);
2629 $i++;
2630 }
cdd23610 2631 if ($item =~ m/^n/) {
02d1d628
AMH
2632 $credit=&clean($item);
2633 $i++;
2634 }
2635 }
2636 }
2637 }
2638 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2639}
2640
02d1d628
AMH
2641# Autoload methods go after =cut, and are processed by the autosplit program.
2642
26431;
2644__END__
2645# Below is the stub of documentation for your module. You better edit it!
2646
2647=head1 NAME
2648
2649Imager - Perl extension for Generating 24 bit Images
2650
2651=head1 SYNOPSIS
2652
0e418f1e
AMH
2653 # Thumbnail example
2654
2655 #!/usr/bin/perl -w
2656 use strict;
10461f9a 2657 use Imager;
02d1d628 2658
0e418f1e
AMH
2659 die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2660 my $file = shift;
2661
2662 my $format;
2663
2664 my $img = Imager->new();
2665 $img->open(file=>$file) or die $img->errstr();
2666
2667 $file =~ s/\.[^.]*$//;
2668
2669 # Create smaller version
2670 my $thumb = $img->scale(scalefactor=>.3);
2671
2672 # Autostretch individual channels
2673 $thumb->filter(type=>'autolevels');
2674
2675 # try to save in one of these formats
2676 SAVE:
2677
2678 for $format ( qw( png gif jpg tiff ppm ) ) {
2679 # Check if given format is supported
2680 if ($Imager::formats{$format}) {
2681 $file.="_low.$format";
2682 print "Storing image as: $file\n";
2683 $thumb->write(file=>$file) or
2684 die $thumb->errstr;
2685 last SAVE;
2686 }
2687 }
2688
2689
0e418f1e 2690
02d1d628
AMH
2691
2692=head1 DESCRIPTION
2693
0e418f1e
AMH
2694Imager is a module for creating and altering images. It can read and
2695write various image formats, draw primitive shapes like lines,and
2696polygons, blend multiple images together in various ways, scale, crop,
2697render text and more.
02d1d628 2698
5df0fac7
AMH
2699=head2 Overview of documentation
2700
2701=over
2702
2703=item Imager
2704
0e418f1e 2705This document - Synopsis Example, Table of Contents and Overview.
5df0fac7
AMH
2706
2707=item Imager::ImageTypes
2708
4b4f5319 2709Basics of constructing image objects with C<new()>:
5df0fac7 2710Direct type/virtual images, RGB(A)/paletted images, 8/16/double
f5fd108b 2711bits/channel, color maps, channel masks, image tags, color
6d0ed98a 2712quantization. Also discusses basic image information methods.
5df0fac7
AMH
2713
2714=item Imager::Files
2715
2716IO interaction, reading/writing images, format specific tags.
2717
2718=item Imager::Draw
2719
f5fd108b 2720Drawing Primitives, lines, boxes, circles, arcs, flood fill.
5df0fac7
AMH
2721
2722=item Imager::Color
2723
2724Color specification.
2725
daa45279 2726=item Imager::Fill
f5fd108b
AMH
2727
2728Fill pattern specification.
2729
5df0fac7
AMH
2730=item Imager::Font
2731
f5fd108b 2732General font rendering, bounding boxes and font metrics.
5df0fac7
AMH
2733
2734=item Imager::Transformations
2735
f5fd108b
AMH
2736Copying, scaling, cropping, flipping, blending, pasting, convert and
2737map.
5df0fac7
AMH
2738
2739=item Imager::Engines
2740
daa45279
AMH
2741Programmable transformations through C<transform()>, C<transform2()>
2742and C<matrix_transform()>.
5df0fac7
AMH
2743
2744=item Imager::Filters
2745
f5fd108b 2746Filters, sharpen, blur, noise, convolve etc. and filter plugins.
5df0fac7
AMH
2747
2748=item Imager::Expr
2749
2750Expressions for evaluation engine used by transform2().
2751
2752=item Imager::Matrix2d
2753
2754Helper class for affine transformations.
2755
2756=item Imager::Fountain
2757
2758Helper for making gradient profiles.
2759
2760=back
2761
2762
0e418f1e 2763
0e418f1e 2764=head2 Basic Overview
02d1d628 2765
55b287f5
AMH
2766An Image object is created with C<$img = Imager-E<gt>new()>.
2767Examples:
02d1d628 2768
55b287f5
AMH
2769 $img=Imager->new(); # create empty image
2770 $img->open(file=>'lena.png',type=>'png') or # read image from file
2771 die $img->errstr(); # give an explanation
2772 # if something failed
02d1d628
AMH
2773
2774or if you want to create an empty image:
2775
2776 $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2777
0e418f1e
AMH
2778This example creates a completely black image of width 400 and height
2779300 and 4 channels.
2780
55b287f5
AMH
2781When an operation fails which can be directly associated with an image
2782the error message is stored can be retrieved with
2783C<$img-E<gt>errstr()>.
2784
2785In cases where no image object is associated with an operation
2786C<$Imager::ERRSTR> is used to report errors not directly associated
2787with an image object.
2788
4b4f5319
AMH
2789The C<Imager-><gt>new> method is described in detail in the
2790Imager::ImageTypes manpage.
2791
f64132d2 2792=head1 SUPPORT
0e418f1e 2793
f64132d2
TC
2794You can ask for help, report bugs or express your undying love for
2795Imager on the Imager-devel mailing list.
02d1d628 2796
f64132d2
TC
2797To subscribe send a message with C<subscribe> in the body to:
2798
2799 imager-devel+request@molar.is
2800
2801or use the form at:
2802
2803 http://www.molar.is/en/lists/imager-devel/
55b287f5 2804 (annonymous is temporarily off due to spam)
f64132d2
TC
2805
2806where you can also find the mailing list archive.
10461f9a 2807
3ed96cd3
TC
2808If you're into IRC, you can typically find the developers in #Imager
2809on irc.rhizomatic.net. As with any IRC channel, the participants
2810could be occupied or asleep, so please be patient.
2811
02d1d628
AMH
2812=head1 BUGS
2813
0e418f1e 2814Bugs are listed individually for relevant pod pages.
02d1d628
AMH
2815
2816=head1 AUTHOR
2817
55b287f5 2818Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
f64132d2 2819(tony@imager.perl.org) See the README for a complete list.
02d1d628 2820
9495ee93 2821=head1 SEE ALSO
02d1d628 2822
55b287f5
AMH
2823perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
2824Imager::Color(3), Imager::Fill(3), Imager::Font(3),
2825Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
2826Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
009db950
AMH
2827
2828Affix::Infix2Postfix(3), Parse::RecDescent(3)
faa9b3e7 2829http://www.eecs.umich.edu/~addi/perl/Imager/
02d1d628
AMH
2830
2831=cut
55b287f5
AMH
2832
2833
2834
2835