All the little fixup changes for the 0.42 release.
[imager.git] / Imager.pm
1 package Imager;
2
3 use strict;
4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS $warn_obsolete);
5 use IO::File;
6
7 use Imager::Color;
8 use Imager::Font;
9
10 @EXPORT_OK = qw(
11                 init
12                 init_log
13                 DSO_open
14                 DSO_close
15                 DSO_funclist
16                 DSO_call
17
18                 load_plugin
19                 unload_plugin
20
21                 i_list_formats
22                 i_has_format
23
24                 i_color_new
25                 i_color_set
26                 i_color_info
27
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
38                 i_line
39                 i_line_aa
40                 i_box
41                 i_box_filled
42                 i_arc
43                 i_circle_aa
44
45                 i_bezier_multi
46                 i_poly_aa
47                 i_poly_aa_cfill
48
49                 i_copyto
50                 i_rubthru
51                 i_scaleaxis
52                 i_scale_nn
53                 i_haar
54                 i_count_colors
55
56                 i_gaussian
57                 i_conv
58
59                 i_convert
60                 i_map
61
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
72                 i_tt_set_aa
73                 i_tt_cp
74                 i_tt_text
75                 i_tt_bbox
76
77                 i_readjpeg_wiol
78                 i_writejpeg_wiol
79
80                 i_readtiff_wiol
81                 i_writetiff_wiol
82                 i_writetiff_wiol_faxable
83
84                 i_readpng_wiol
85                 i_writepng_wiol
86
87                 i_readgif
88                 i_readgif_wiol
89                 i_readgif_callback
90                 i_writegif
91                 i_writegifmc
92                 i_writegif_gen
93                 i_writegif_callback
94
95                 i_readpnm_wiol
96                 i_writeppm_wiol
97
98                 i_readraw_wiol
99                 i_writeraw_wiol
100
101                 i_contrast
102                 i_hardinvert
103                 i_noise
104                 i_bumpmap
105                 i_postlevels
106                 i_mosaic
107                 i_watermark
108
109                 malloc_state
110
111                 list_formats
112
113                 i_gifquant
114
115                 newfont
116                 newcolor
117                 newcolour
118                 NC
119                 NF
120 );
121
122 @EXPORT=qw(
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
146 BEGIN {
147   require Exporter;
148   require DynaLoader;
149
150   $VERSION = '0.42';
151   @ISA = qw(Exporter DynaLoader);
152   bootstrap Imager $VERSION;
153 }
154
155 BEGIN {
156   i_init_fonts(); # Initialize font engines
157   Imager::Font::__init();
158   for(i_list_formats()) { $formats{$_}++; }
159
160   if ($formats{'t1'}) {
161     i_t1_set_aa(1);
162   }
163
164   if (!$formats{'t1'} and !$formats{'tt'} 
165       && !$formats{'ft2'} && !$formats{'w32'}) {
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
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
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                            };
235   $filters{gaussian} = {
236                         callseq => [ 'image', 'stddev' ],
237                         defaults => { },
238                         callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
239                        };
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 },
250      callsub => sub {
251        my %hsh = @_;
252        i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
253                  $hsh{lightx}, $hsh{lighty}, $hsh{st});
254      },
255     };
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     };
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     };
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                                   },
320                   combine => {
321                               none      => 0,
322                               normal    => 1,
323                               multiply  => 2, mult => 2,
324                               dissolve  => 3,
325                               add       => 4,
326                               subtract  => 5, 'sub' => 5,
327                               diff      => 6,
328                               lighten   => 7,
329                               darken    => 8,
330                               hue       => 9,
331                               sat       => 10,
332                               value     => 11,
333                               color     => 12,
334                              },
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     };
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     };
364
365   $FORMATGUESS=\&def_guess_type;
366
367   $warn_obsolete = 1;
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
385 sub init_log {
386         m_init_log($_[0],$_[1]);
387         log_entry("Imager $VERSION starting\n", 1);
388 }
389
390
391 sub init {
392   my %parms=(loglevel=>1,@_);
393   if ($parms{'log'}) {
394     init_log($parms{'log'},$parms{'loglevel'});
395   }
396
397   if (exists $parms{'warn_obsolete'}) {
398     $warn_obsolete = $parms{'warn_obsolete'};
399   }
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 #    }
406   if (exists $parms{'t1log'}) {
407     i_init_fonts($parms{'t1log'});
408   }
409 }
410
411 END {
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
422 sub 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
445 sub 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
459 # take the results of i_error() and make a message out of it
460 sub _error_as_msg {
461   return join(": ", map $_->[0], i_errors());
462 }
463
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
472 sub _color {
473   my $arg = shift;
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 . "";
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 {
487       if ($copy =~ /^HASH\(/) {
488         $result = Imager::Color->new(%$arg);
489       }
490       elsif ($copy =~ /^ARRAY\(/) {
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
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
520 sub 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
533 # Copy an entire image with no changes 
534 # - if an image has magic the copy of it will not be magical
535
536 sub 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
548 sub 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
568 sub crop {
569   my $self=shift;
570   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
571   my %hsh=(left=>0,right=>$self->getwidth(),top=>0,bottom=>$self->getheight(),@_);
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;
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
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
589   if ($hsh{'width'}) {
590     $l=int(0.5+($w-$hsh{'width'})/2);
591     $r=$l+$hsh{'width'};
592   } else {
593     $hsh{'width'}=$r-$l;
594   }
595   if ($hsh{'height'}) {
596     $b=int(0.5+($h-$hsh{'height'})/2);
597     $t=$h+$hsh{'height'};
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
605   my $dst=Imager->new(xsize=>$hsh{'width'}, ysize=>$hsh{'height'}, channels=>$self->getchannels());
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
614 sub img_set {
615   my $self=shift;
616
617   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
618
619   if (defined($self->{IMG})) {
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});
623     undef($self->{IMG});
624   }
625
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   }
630   elsif ($hsh{bits} eq 'double') {
631     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
632   }
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
643 sub 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
666 sub 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
687 sub 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
700 sub 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
709 sub 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
717 sub 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
736 sub colorcount {
737   i_colorcount($_[0]{IMG});
738 }
739
740 sub maxcolors {
741   i_maxcolors($_[0]{IMG});
742 }
743
744 sub 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
752 sub bits {
753   my $self = shift;
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;
759 }
760
761 sub type {
762   my $self = shift;
763   if ($self->{IMG}) {
764     return i_img_type($self->{IMG}) ? "paletted" : "direct";
765   }
766 }
767
768 sub virtual {
769   my $self = shift;
770   $self->{IMG} and i_img_virtual($self->{IMG});
771 }
772
773 sub 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
808 sub 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
856 sub deltag {
857   my $self = shift;
858   my %opts = @_;
859
860   return 0 unless $self->{IMG};
861
862   if (defined $opts{'index'}) {
863     return i_tags_delete($self->{IMG}, $opts{'index'});
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   }
875 }
876
877 sub 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
893
894 sub _get_reader_io {
895   my ($self, $input) = @_;
896
897         if ($input->{io}) {
898                 return $input->{io}, undef;
899         }
900   elsif ($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 (!$input->{seekcb}) {
925       $self->_set_error("Need 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
945 sub _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     }
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);
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
995 # Read an image from file
996
997 sub read {
998   my $self = shift;
999   my %input=@_;
1000
1001   if (defined($self->{IMG})) {
1002     # let IIM_DESTROY do the destruction, since the image may be
1003     # referenced from elsewhere
1004     #i_img_destroy($self->{IMG});
1005     undef($self->{IMG});
1006   }
1007
1008   # FIXME: Find the format here if not specified
1009   # yes the code isn't here yet - next week maybe?
1010   # Next week?  Are you high or something?  That comment
1011   # has been there for half a year dude.
1012   # Look, i just work here, ok?
1013
1014   my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1015
1016   unless ($input{'type'}) {
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'); 
1022     return undef;
1023   }
1024
1025   # Setup data source
1026   if ( $input{'type'} eq 'jpeg' ) {
1027     ($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
1028     if ( !defined($self->{IMG}) ) {
1029       $self->{ERRSTR}='unable to read jpeg image'; return undef;
1030     }
1031     $self->{DEBUG} && print "loading a jpeg file\n";
1032     return $self;
1033   }
1034
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;
1039     }
1040     $self->{DEBUG} && print "loading a tiff file\n";
1041     return $self;
1042   }
1043
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;
1048     }
1049     $self->{DEBUG} && print "loading a pnm file\n";
1050     return $self;
1051   }
1052
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;
1058     }
1059     $self->{DEBUG} && print "loading a png file\n";
1060   }
1061
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;
1067     }
1068     $self->{DEBUG} && print "loading a bmp file\n";
1069   }
1070
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;
1076     }
1077     if ($input{colors}) {
1078       my $colors;
1079       ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1080       if ($colors) {
1081         ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1082       }
1083     }
1084     else {
1085       $self->{IMG} =i_readgif_wiol( $IO );
1086     }
1087     if ( !defined($self->{IMG}) ) {
1088       $self->{ERRSTR}=$self->_error_as_msg();
1089       return undef;
1090     }
1091     $self->{DEBUG} && print "loading a gif file\n";
1092   }
1093
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;
1099     }
1100     $self->{DEBUG} && print "loading a tga file\n";
1101   }
1102
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();
1107       return undef;
1108     }
1109     $self->{DEBUG} && print "loading a tga file\n";
1110   }
1111
1112
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;
1119     }
1120
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;
1130     }
1131     $self->{DEBUG} && print "loading a raw file\n";
1132   }
1133
1134   return $self;
1135 }
1136
1137 sub _fix_gif_positions {
1138   my ($opts, $opt, $msg, @imgs) = @_;
1139
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++];
1145     $img->settag(name=>'gif_left', value=>$x);
1146     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1147   }
1148   $$msg .= "replaced with the gif_left and gif_top tags";
1149 }
1150
1151 my %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
1160 sub _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
1225 # Write an image to file
1226 sub write {
1227   my $self = shift;
1228   my %input=(jpegquality=>75,
1229              gifquant=>'mc',
1230              lmdither=>6.0,
1231              lmfixed=>[],
1232              idstring=>"",
1233              compress=>1,
1234              wierdpack=>0,
1235              fax_fine=>1, @_);
1236   my $rc;
1237
1238   $self->_set_opts(\%input, "i_", $self)
1239     or return undef;
1240
1241   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1242
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   }
1250
1251   if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
1252
1253   my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1254     or return undef;
1255
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;
1261
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';
1265         return undef;
1266       }
1267     } else {
1268       if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1269         $self->{ERRSTR}='Could not write to buffer';
1270         return undef;
1271       }
1272     }
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;
1318
1319     if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1320       $self->{ERRSTR}=$self->_error_as_msg();
1321       return undef;
1322     }
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});
1339   }
1340
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   }
1349   return $self;
1350 }
1351
1352 sub write_multi {
1353   my ($class, $opts, @images) = @_;
1354
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   }
1367   $class->_set_opts($opts, "i_", @images)
1368     or return;
1369   my @work = map $_->{IMG}, @images;
1370   my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1371     or return undef;
1372   if ($opts->{'type'} eq 'gif') {
1373     $class->_set_opts($opts, "gif_", @images)
1374       or return;
1375     my $gif_delays = $opts->{gif_delays};
1376     local $opts->{gif_delays} = $gif_delays;
1377     if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1378       # assume the caller wants the same delay for each frame
1379       $opts->{gif_delays} = [ ($gif_delays) x @images ];
1380     }
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') {
1386     $class->_set_opts($opts, "tiff_", @images)
1387       or return;
1388     $class->_set_opts($opts, "exif_", @images)
1389       or return;
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);
1394     }
1395     else {
1396       $res = i_writetiff_multi_wiol($IO, @work);
1397     }
1398     $res or $class->_set_error($class->_error_as_msg());
1399     return $res;
1400   }
1401   else {
1402     $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
1403     return 0;
1404   }
1405 }
1406
1407 # read multiple images from a file
1408 sub read_multi {
1409   my ($class, %opts) = @_;
1410
1411   if ($opts{file} && !exists $opts{'type'}) {
1412     # guess the type 
1413     my $type = $FORMATGUESS->($opts{file});
1414     $opts{'type'} = $type;
1415   }
1416   unless ($opts{'type'}) {
1417     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1418     return;
1419   }
1420
1421   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1422     or return;
1423   if ($opts{'type'} eq 'gif') {
1424     my @imgs;
1425     @imgs = i_readgif_multi_wiol($IO);
1426     if (@imgs) {
1427       return map { 
1428         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager' 
1429       } @imgs;
1430     }
1431     else {
1432       $ERRSTR = _error_as_msg();
1433       return;
1434     }
1435   }
1436   elsif ($opts{'type'} eq 'tiff') {
1437     my @imgs = i_readtiff_multi_wiol($IO, -1);
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
1449   $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
1450   return;
1451 }
1452
1453 # Destroy an Imager object
1454
1455 sub DESTROY {
1456   my $self=shift;
1457   #    delete $instances{$self};
1458   if (defined($self->{IMG})) {
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});
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
1473 sub filter {
1474   my $self=shift;
1475   my %input=@_;
1476   my %hsh;
1477   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1478
1479   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1480
1481   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1482     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1483   }
1484
1485   if ($filters{$input{'type'}}{names}) {
1486     my $names = $filters{$input{'type'}}{names};
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   }
1493   if (defined($filters{$input{'type'}}{defaults})) {
1494     %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
1495   } else {
1496     %hsh=('image',$self->{IMG},%input);
1497   }
1498
1499   my @cs=@{$filters{$input{'type'}}{callseq}};
1500
1501   for(@cs) {
1502     if (!defined($hsh{$_})) {
1503       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1504     }
1505   }
1506
1507   &{$filters{$input{'type'}}{callsub}}(%hsh);
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
1519 sub scale {
1520   my $self=shift;
1521   my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
1522   my $img = Imager->new();
1523   my $tmp = Imager->new();
1524
1525   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1526
1527   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
1528     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
1529     if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1530     if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
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
1551 sub 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
1570 sub 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
1593 sub 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'},
1614                                              {op=>'-','type'=>'unary',trans=>'u-'},
1615                                              {op=>'**'},
1616                                              {op=>'func','type'=>'unary'}],
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
1685 sub 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;
1702     }
1703   }
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   }
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   }
1729
1730   my $img = Imager->new();
1731   $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, 
1732                              $channels, $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   }
1739
1740   return $img;
1741 }
1742
1743 sub 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
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})) {
1758     $self->{ERRSTR} = $self->_error_as_msg();
1759     return undef;
1760   }
1761   return $self;
1762 }
1763
1764
1765 sub flip {
1766   my $self  = shift;
1767   my %opts  = @_;
1768   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
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
1776 sub 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
1821 sub 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;
1828
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;
1844
1845 # These two are supported for legacy code only
1846
1847 sub i_color_new {
1848   return Imager::Color->new(@_);
1849 }
1850
1851 sub i_color_set {
1852   return Imager::Color::set(@_);
1853 }
1854
1855 # Draws a box between the specified corner points.
1856 sub 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
1869   if ($opts{filled}) { 
1870     my $color = _color($opts{'color'});
1871     unless ($color) { 
1872       $self->{ERRSTR} = $Imager::ERRSTR; 
1873       return; 
1874     }
1875     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1876                  $opts{ymax}, $color); 
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';
1882       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1883         $self->{ERRSTR} = $Imager::ERRSTR;
1884         return undef;
1885       }
1886     }
1887     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1888                 $opts{ymax},$opts{fill}{fill});
1889   }
1890   else {
1891     my $color = _color($opts{'color'});
1892     unless ($color) { 
1893       $self->{ERRSTR} = $Imager::ERRSTR;
1894       return;
1895     }
1896     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
1897           $color);
1898   }
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
1904 sub 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, @_);
1913   if ($opts{fill}) {
1914     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1915       # assume it's a hash ref
1916       require 'Imager/Fill.pm';
1917       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1918         $self->{ERRSTR} = $Imager::ERRSTR;
1919         return;
1920       }
1921     }
1922     i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
1923                 $opts{'d2'}, $opts{fill}{fill});
1924   }
1925   else {
1926     my $color = _color($opts{'color'});
1927     unless ($color) { 
1928       $self->{ERRSTR} = $Imager::ERRSTR; 
1929       return; 
1930     }
1931     if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
1932       i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, 
1933                   $color);
1934     }
1935     else {
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       }
1946     }
1947   }
1948
1949   return $self;
1950 }
1951
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.
1955
1956 sub line {
1957   my $self=shift;
1958   my $dflcl=i_color_new(0,0,0,0);
1959   my %opts=(color=>$dflcl,
1960             endp => 1,
1961             @_);
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
1967   my $color = _color($opts{'color'});
1968   unless ($color) {
1969     $self->{ERRSTR} = $Imager::ERRSTR;
1970     return;
1971   }
1972
1973   $opts{antialias} = $opts{aa} if defined $opts{aa};
1974   if ($opts{antialias}) {
1975     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
1976               $color, $opts{endp});
1977   } else {
1978     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
1979            $color, $opts{endp});
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
1987 sub 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
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};
2008   if ($opts{antialias}) {
2009     for $pt(@points) {
2010       if (defined($ls)) { 
2011         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2012       }
2013       $ls=$pt;
2014     }
2015   } else {
2016     for $pt(@points) {
2017       if (defined($ls)) { 
2018         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2019       }
2020       $ls=$pt;
2021     }
2022   }
2023   return $self;
2024 }
2025
2026 sub 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
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 {
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);
2062   }
2063
2064   return $self;
2065 }
2066
2067
2068 # this the multipoint bezier curve
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
2073 sub 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
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);
2097   return $self;
2098 }
2099
2100 sub flood_fill {
2101   my $self = shift;
2102   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2103   my $rc;
2104
2105   unless (exists $opts{'x'} && exists $opts{'y'}) {
2106     $self->{ERRSTR} = "missing seed x and y parameters";
2107     return undef;
2108   }
2109
2110   if ($opts{fill}) {
2111     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2112       # assume it's a hash ref
2113       require 'Imager/Fill.pm';
2114       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2115         $self->{ERRSTR} = $Imager::ERRSTR;
2116         return;
2117       }
2118     }
2119     $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2120   }
2121   else {
2122     my $color = _color($opts{'color'});
2123     unless ($color) {
2124       $self->{ERRSTR} = $Imager::ERRSTR;
2125       return;
2126     }
2127     $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2128   }
2129   if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
2130 }
2131
2132 sub 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) {
2148       $self->{ERRSTR} = 'length of x and y mismatch';
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
2174 sub getpixel {
2175   my $self = shift;
2176
2177   my %opts = ( "type"=>'8bit', @_);
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;
2192     if ($opts{"type"} eq '8bit') {
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 {
2205     if ($opts{"type"} eq '8bit') {
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
2216 # make an identity matrix of the given size
2217 sub _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
2228 sub 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 }
2326
2327
2328 # general function to map an image through lookup tables
2329
2330 sub map {
2331   my ($self, %opts) = @_;
2332   my @chlist = qw( red green blue alpha );
2333
2334   if (!exists($opts{'maps'})) {
2335     # make maps from channel maps
2336     my $chnum;
2337     for $chnum (0..$#chlist) {
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       }
2343     }
2344   }
2345   if ($opts{'maps'} and $self->{IMG}) {
2346     i_map($self->{IMG}, $opts{'maps'} );
2347   }
2348   return $self;
2349 }
2350
2351 sub 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
2372 # destructive border - image is shrunk by one pixel all around
2373
2374 sub 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
2383 sub 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
2391 sub 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
2399 sub 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
2407 sub 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
2415 sub 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
2424 sub getcolorcount {
2425   my $self=shift;
2426   my %opts=('maxcolors'=>2**30,@_);
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
2434 sub 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
2451   unless ($input{font}->draw(image=>$self, %input)) {
2452     $self->{ERRSTR} = $self->_error_as_msg();
2453     return;
2454   }
2455
2456   return $self;
2457 }
2458
2459 # Shortcuts that can be exported
2460
2461 sub newcolor { Imager::Color->new(@_); }
2462 sub 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
2473 sub errstr { 
2474   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2475 }
2476
2477 sub _set_error {
2478   my ($self, $msg) = @_;
2479
2480   if (ref $self) {
2481     $self->{ERRSTR} = $msg;
2482   }
2483   else {
2484     $ERRSTR = $msg;
2485   }
2486   return;
2487 }
2488
2489 # Default guess for the type of an image from extension
2490
2491 sub 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");
2499   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
2500   return 'tga'  if ($ext eq "tga");
2501   return 'rgb'  if ($ext eq "rgb");
2502   return 'gif'  if ($ext eq "gif");
2503   return 'raw'  if ($ext eq "raw");
2504   return ();
2505 }
2506
2507 # get the minimum of a list
2508
2509 sub min {
2510   my $mx=shift;
2511   for(@_) { if ($_<$mx) { $mx=$_; }}
2512   return $mx;
2513 }
2514
2515 # get the maximum of a list
2516
2517 sub max {
2518   my $mx=shift;
2519   for(@_) { if ($_>$mx) { $mx=$_; }}
2520   return $mx;
2521 }
2522
2523 # string stuff for iptc headers
2524
2525 sub 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
2537 sub 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) {
2553         if ($item =~ m/^x/) {
2554           $caption=&clean($item);
2555           $i++;
2556         }
2557         if ($item =~ m/^P/) {
2558           $photogr=&clean($item);
2559           $i++;
2560         }
2561         if ($item =~ m/^i/) {
2562           $headln=&clean($item);
2563           $i++;
2564         }
2565         if ($item =~ m/^n/) {
2566           $credit=&clean($item);
2567           $i++;
2568         }
2569       }
2570     }
2571   }
2572   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2573 }
2574
2575 # Autoload methods go after =cut, and are processed by the autosplit program.
2576
2577 1;
2578 __END__
2579 # Below is the stub of documentation for your module. You better edit it!
2580
2581 =head1 NAME
2582
2583 Imager - Perl extension for Generating 24 bit Images
2584
2585 =head1 SYNOPSIS
2586
2587   # Thumbnail example
2588
2589   #!/usr/bin/perl -w
2590   use strict;
2591   use Imager;
2592
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
2624
2625
2626 =head1 DESCRIPTION
2627
2628 Imager is a module for creating and altering images.  It can read and
2629 write various image formats, draw primitive shapes like lines,and
2630 polygons, blend multiple images together in various ways, scale, crop,
2631 render text and more.
2632
2633 =head2 Overview of documentation
2634
2635 =over
2636
2637 =item Imager
2638
2639 This document - Synopsis Example, Table of Contents and Overview.
2640
2641 =item Imager::ImageTypes
2642
2643 Basics of constructing image objects with C<new()>:
2644 Direct type/virtual images, RGB(A)/paletted images, 8/16/double
2645 bits/channel, color maps, channel masks, image tags, color
2646 quantization.  Also discusses basic image information methods.
2647
2648 =item Imager::Files
2649
2650 IO interaction, reading/writing images, format specific tags.
2651
2652 =item Imager::Draw
2653
2654 Drawing Primitives, lines, boxes, circles, arcs, flood fill.
2655
2656 =item Imager::Color
2657
2658 Color specification.
2659
2660 =item Imager::Fill
2661
2662 Fill pattern specification.
2663
2664 =item Imager::Font
2665
2666 General font rendering, bounding boxes and font metrics.
2667
2668 =item Imager::Transformations
2669
2670 Copying, scaling, cropping, flipping, blending, pasting, convert and
2671 map.
2672
2673 =item Imager::Engines
2674
2675 Programmable transformations through C<transform()>, C<transform2()>
2676 and C<matrix_transform()>.
2677
2678 =item Imager::Filters
2679
2680 Filters, sharpen, blur, noise, convolve etc. and filter plugins.
2681
2682 =item Imager::Expr
2683
2684 Expressions for evaluation engine used by transform2().
2685
2686 =item Imager::Matrix2d
2687
2688 Helper class for affine transformations.
2689
2690 =item Imager::Fountain
2691
2692 Helper for making gradient profiles.
2693
2694 =back
2695
2696
2697
2698 =head2 Basic Overview
2699
2700 An Image object is created with C<$img = Imager-E<gt>new()>.
2701 Examples:
2702
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
2707
2708 or if you want to create an empty image:
2709
2710   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2711
2712 This example creates a completely black image of width 400 and height
2713 300 and 4 channels.
2714
2715 When an operation fails which can be directly associated with an image
2716 the error message is stored can be retrieved with
2717 C<$img-E<gt>errstr()>.
2718
2719 In cases where no image object is associated with an operation
2720 C<$Imager::ERRSTR> is used to report errors not directly associated
2721 with an image object.
2722
2723 The C<Imager-E<gt>new> method is described in detail in the 
2724 Imager::ImageTypes manpage.
2725
2726 =head1 SUPPORT
2727
2728 You can ask for help, report bugs or express your undying love for
2729 Imager on the Imager-devel mailing list.
2730
2731 To subscribe send a message with C<subscribe> in the body to:
2732
2733    imager-devel+request@molar.is
2734
2735 or use the form at:
2736
2737    http://www.molar.is/en/lists/imager-devel/
2738    (annonymous is temporarily off due to spam)
2739
2740 where you can also find the mailing list archive.
2741
2742 If you're into IRC, you can typically find the developers in #Imager
2743 on irc.rhizomatic.net.  As with any IRC channel, the participants
2744 could be occupied or asleep, so please be patient.
2745
2746 =head1 BUGS
2747
2748 Bugs are listed individually for relevant pod pages.
2749
2750 =head1 AUTHOR
2751
2752 Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
2753 (tony@imager.perl.org) See the README for a complete list.
2754
2755 =head1 SEE ALSO
2756
2757 perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
2758 Imager::Color(3), Imager::Fill(3), Imager::Font(3),
2759 Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
2760 Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
2761
2762 Affix::Infix2Postfix(3), Parse::RecDescent(3)
2763 http://imager.perl.org/~addi/perl/Imager/
2764
2765 =cut
2766
2767
2768
2769