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