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