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