added Artur's OSX dlload() emulation, with minor changes
[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);
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_draw
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.39';
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
368 #
369 # Non methods
370 #
371
372 # initlize Imager
373 # NOTE: this might be moved to an import override later on
374
375 #sub import {
376 #  my $pack = shift;
377 #  (look through @_ for special tags, process, and remove them);   
378 #  use Data::Dumper;
379 #  print Dumper($pack);
380 #  print Dumper(@_);
381 #}
382
383 sub init {
384   my %parms=(loglevel=>1,@_);
385   if ($parms{'log'}) {
386     init_log($parms{'log'},$parms{'loglevel'});
387   }
388
389 #    if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
390 #    if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
391 #       i_init_fonts();
392 #       $fontstate='ok';
393 #    }
394 }
395
396 END {
397   if ($DEBUG) {
398     print "shutdown code\n";
399     #   for(keys %instances) { $instances{$_}->DESTROY(); }
400     malloc_state(); # how do decide if this should be used? -- store something from the import
401     print "Imager exiting\n";
402   }
403 }
404
405 # Load a filter plugin 
406
407 sub load_plugin {
408   my ($filename)=@_;
409   my $i;
410   my ($DSO_handle,$str)=DSO_open($filename);
411   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
412   my %funcs=DSO_funclist($DSO_handle);
413   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
414   $i=0;
415   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
416
417   $DSOs{$filename}=[$DSO_handle,\%funcs];
418
419   for(keys %funcs) { 
420     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
421     $DEBUG && print "eval string:\n",$evstr,"\n";
422     eval $evstr;
423     print $@ if $@;
424   }
425   return 1;
426 }
427
428 # Unload a plugin
429
430 sub unload_plugin {
431   my ($filename)=@_;
432
433   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
434   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
435   for(keys %{$funcref}) {
436     delete $filters{$_};
437     $DEBUG && print "unloading: $_\n";
438   }
439   my $rc=DSO_close($DSO_handle);
440   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
441   return 1;
442 }
443
444 # take the results of i_error() and make a message out of it
445 sub _error_as_msg {
446   return join(": ", map $_->[0], i_errors());
447 }
448
449 # this function tries to DWIM for color parameters
450 #  color objects are used as is
451 #  simple scalars are simply treated as single parameters to Imager::Color->new
452 #  hashrefs are treated as named argument lists to Imager::Color->new
453 #  arrayrefs are treated as list arguments to Imager::Color->new iff any
454 #    parameter is > 1
455 #  other arrayrefs are treated as list arguments to Imager::Color::Float
456
457 sub _color {
458   my $arg = shift;
459   # perl 5.6.0 seems to do weird things to $arg if we don't make an 
460   # explicitly stringified copy
461   # I vaguely remember a bug on this on p5p, but couldn't find it
462   # through bugs.perl.org (I had trouble getting it to find any bugs)
463   my $copy = $arg . "";
464   my $result;
465
466   if (ref $arg) {
467     if (UNIVERSAL::isa($arg, "Imager::Color")
468         || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
469       $result = $arg;
470     }
471     else {
472       if ($copy =~ /^HASH\(/) {
473         $result = Imager::Color->new(%$arg);
474       }
475       elsif ($copy =~ /^ARRAY\(/) {
476         if (grep $_ > 1, @$arg) {
477           $result = Imager::Color->new(@$arg);
478         }
479         else {
480           $result = Imager::Color::Float->new(@$arg);
481         }
482       }
483       else {
484         $Imager::ERRSTR = "Not a color";
485       }
486     }
487   }
488   else {
489     # assume Imager::Color::new knows how to handle it
490     $result = Imager::Color->new($arg);
491   }
492
493   return $result;
494 }
495
496
497 #
498 # Methods to be called on objects.
499 #
500
501 # Create a new Imager object takes very few parameters.
502 # usually you call this method and then call open from
503 # the resulting object
504
505 sub new {
506   my $class = shift;
507   my $self ={};
508   my %hsh=@_;
509   bless $self,$class;
510   $self->{IMG}=undef;    # Just to indicate what exists
511   $self->{ERRSTR}=undef; #
512   $self->{DEBUG}=$DEBUG;
513   $self->{DEBUG} && print "Initialized Imager\n";
514   if ($hsh{xsize} && $hsh{ysize}) { $self->img_set(%hsh); }
515   return $self;
516 }
517
518 # Copy an entire image with no changes 
519 # - if an image has magic the copy of it will not be magical
520
521 sub copy {
522   my $self = shift;
523   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
524
525   my $newcopy=Imager->new();
526   $newcopy->{IMG}=i_img_new();
527   i_copy($newcopy->{IMG},$self->{IMG});
528   return $newcopy;
529 }
530
531 # Paste a region
532
533 sub paste {
534   my $self = shift;
535   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
536   my %input=(left=>0, top=>0, @_);
537   unless($input{img}) {
538     $self->{ERRSTR}="no source image";
539     return;
540   }
541   $input{left}=0 if $input{left} <= 0;
542   $input{top}=0 if $input{top} <= 0;
543   my $src=$input{img};
544   my($r,$b)=i_img_info($src->{IMG});
545
546   i_copyto($self->{IMG}, $src->{IMG}, 
547            0,0, $r, $b, $input{left}, $input{top});
548   return $self;  # What should go here??
549 }
550
551 # Crop an image - i.e. return a new image that is smaller
552
553 sub crop {
554   my $self=shift;
555   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
556   my %hsh=(left=>0,right=>0,top=>0,bottom=>0,@_);
557
558   my ($w,$h,$l,$r,$b,$t)=($self->getwidth(),$self->getheight(),
559                                 @hsh{qw(left right bottom top)});
560   $l=0 if not defined $l;
561   $t=0 if not defined $t;
562
563   $r||=$l+delete $hsh{'width'}    if defined $l and exists $hsh{'width'};
564   $b||=$t+delete $hsh{'height'}   if defined $t and exists $hsh{'height'};
565   $l||=$r-delete $hsh{'width'}    if defined $r and exists $hsh{'width'};
566   $t||=$b-delete $hsh{'height'}   if defined $b and exists $hsh{'height'};
567
568   $r=$self->getwidth if not defined $r;
569   $b=$self->getheight if not defined $b;
570
571   ($l,$r)=($r,$l) if $l>$r;
572   ($t,$b)=($b,$t) if $t>$b;
573
574   if ($hsh{'width'}) {
575     $l=int(0.5+($w-$hsh{'width'})/2);
576     $r=$l+$hsh{'width'};
577   } else {
578     $hsh{'width'}=$r-$l;
579   }
580   if ($hsh{'height'}) {
581     $b=int(0.5+($h-$hsh{'height'})/2);
582     $t=$h+$hsh{'height'};
583   } else {
584     $hsh{'height'}=$b-$t;
585   }
586
587 #    print "l=$l, r=$r, h=$hsh{'width'}\n";
588 #    print "t=$t, b=$b, w=$hsh{'height'}\n";
589
590   my $dst=Imager->new(xsize=>$hsh{'width'}, ysize=>$hsh{'height'}, channels=>$self->getchannels());
591
592   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
593   return $dst;
594 }
595
596 # Sets an image to a certain size and channel number
597 # if there was previously data in the image it is discarded
598
599 sub img_set {
600   my $self=shift;
601
602   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
603
604   if (defined($self->{IMG})) {
605     # let IIM_DESTROY destroy it, it's possible this image is
606     # referenced from a virtual image (like masked)
607     #i_img_destroy($self->{IMG});
608     undef($self->{IMG});
609   }
610
611   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
612     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
613                                  $hsh{maxcolors} || 256);
614   }
615   elsif ($hsh{bits} eq 'double') {
616     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
617   }
618   elsif ($hsh{bits} == 16) {
619     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
620   }
621   else {
622     $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
623                                      $hsh{'channels'});
624   }
625 }
626
627 # created a masked version of the current image
628 sub masked {
629   my $self = shift;
630
631   $self or return undef;
632   my %opts = (left    => 0, 
633               top     => 0, 
634               right   => $self->getwidth, 
635               bottom  => $self->getheight,
636               @_);
637   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
638
639   my $result = Imager->new;
640   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left}, 
641                                     $opts{top}, $opts{right} - $opts{left},
642                                     $opts{bottom} - $opts{top});
643   # keep references to the mask and base images so they don't
644   # disappear on us
645   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
646
647   $result;
648 }
649
650 # convert an RGB image into a paletted image
651 sub to_paletted {
652   my $self = shift;
653   my $opts;
654   if (@_ != 1 && !ref $_[0]) {
655     $opts = { @_ };
656   }
657   else {
658     $opts = shift;
659   }
660
661   my $result = Imager->new;
662   $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
663
664   #print "Type ", i_img_type($result->{IMG}), "\n";
665
666   $result->{IMG} or undef $result;
667
668   return $result;
669 }
670
671 # convert a paletted (or any image) to an 8-bit/channel RGB images
672 sub to_rgb8 {
673   my $self = shift;
674   my $result;
675
676   if ($self->{IMG}) {
677     $result = Imager->new;
678     $result->{IMG} = i_img_to_rgb($self->{IMG})
679       or undef $result;
680   }
681
682   return $result;
683 }
684
685 sub addcolors {
686   my $self = shift;
687   my %opts = (colors=>[], @_);
688
689   @{$opts{colors}} or return undef;
690
691   $self->{IMG} and i_addcolors($self->{IMG}, @{$opts{colors}});
692 }
693
694 sub setcolors {
695   my $self = shift;
696   my %opts = (start=>0, colors=>[], @_);
697   @{$opts{colors}} or return undef;
698
699   $self->{IMG} and i_setcolors($self->{IMG}, $opts{start}, @{$opts{colors}});
700 }
701
702 sub getcolors {
703   my $self = shift;
704   my %opts = @_;
705   if (!exists $opts{start} && !exists $opts{count}) {
706     # get them all
707     $opts{start} = 0;
708     $opts{count} = $self->colorcount;
709   }
710   elsif (!exists $opts{count}) {
711     $opts{count} = 1;
712   }
713   elsif (!exists $opts{start}) {
714     $opts{start} = 0;
715   }
716   
717   $self->{IMG} and 
718     return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
719 }
720
721 sub colorcount {
722   i_colorcount($_[0]{IMG});
723 }
724
725 sub maxcolors {
726   i_maxcolors($_[0]{IMG});
727 }
728
729 sub findcolor {
730   my $self = shift;
731   my %opts = @_;
732   $opts{color} or return undef;
733
734   $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
735 }
736
737 sub bits {
738   my $self = shift;
739   my $bits = $self->{IMG} && i_img_bits($self->{IMG});
740   if ($bits && $bits == length(pack("d", 1)) * 8) {
741     $bits = 'double';
742   }
743   $bits;
744 }
745
746 sub type {
747   my $self = shift;
748   if ($self->{IMG}) {
749     return i_img_type($self->{IMG}) ? "paletted" : "direct";
750   }
751 }
752
753 sub virtual {
754   my $self = shift;
755   $self->{IMG} and i_img_virtual($self->{IMG});
756 }
757
758 sub tags {
759   my ($self, %opts) = @_;
760
761   $self->{IMG} or return;
762
763   if (defined $opts{name}) {
764     my @result;
765     my $start = 0;
766     my $found;
767     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
768       push @result, (i_tags_get($self->{IMG}, $found))[1];
769       $start = $found+1;
770     }
771     return wantarray ? @result : $result[0];
772   }
773   elsif (defined $opts{code}) {
774     my @result;
775     my $start = 0;
776     my $found;
777     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
778       push @result, (i_tags_get($self->{IMG}, $found))[1];
779       $start = $found+1;
780     }
781     return @result;
782   }
783   else {
784     if (wantarray) {
785       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
786     }
787     else {
788       return i_tags_count($self->{IMG});
789     }
790   }
791 }
792
793 sub addtag {
794   my $self = shift;
795   my %opts = @_;
796
797   return -1 unless $self->{IMG};
798   if ($opts{name}) {
799     if (defined $opts{value}) {
800       if ($opts{value} =~ /^\d+$/) {
801         # add as a number
802         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
803       }
804       else {
805         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
806       }
807     }
808     elsif (defined $opts{data}) {
809       # force addition as a string
810       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
811     }
812     else {
813       $self->{ERRSTR} = "No value supplied";
814       return undef;
815     }
816   }
817   elsif ($opts{code}) {
818     if (defined $opts{value}) {
819       if ($opts{value} =~ /^\d+$/) {
820         # add as a number
821         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
822       }
823       else {
824         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
825       }
826     }
827     elsif (defined $opts{data}) {
828       # force addition as a string
829       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
830     }
831     else {
832       $self->{ERRSTR} = "No value supplied";
833       return undef;
834     }
835   }
836   else {
837     return undef;
838   }
839 }
840
841 sub deltag {
842   my $self = shift;
843   my %opts = @_;
844
845   return 0 unless $self->{IMG};
846
847   if (defined $opts{'index'}) {
848     return i_tags_delete($self->{IMG}, $opts{'index'});
849   }
850   elsif (defined $opts{name}) {
851     return i_tags_delbyname($self->{IMG}, $opts{name});
852   }
853   elsif (defined $opts{code}) {
854     return i_tags_delbycode($self->{IMG}, $opts{code});
855   }
856   else {
857     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
858     return 0;
859   }
860 }
861
862 my @needseekcb = qw/tiff/;
863 my %needseekcb = map { $_, $_ } @needseekcb;
864
865
866 sub _get_reader_io {
867   my ($self, $input, $type) = @_;
868
869   if ($input->{fd}) {
870     return io_new_fd($input->{fd});
871   }
872   elsif ($input->{fh}) {
873     my $fd = fileno($input->{fh});
874     unless ($fd) {
875       $self->_set_error("Handle in fh option not opened");
876       return;
877     }
878     return io_new_fd($fd);
879   }
880   elsif ($input->{file}) {
881     my $file = IO::File->new($input->{file}, "r");
882     unless ($file) {
883       $self->_set_error("Could not open $input->{file}: $!");
884       return;
885     }
886     binmode $file;
887     return (io_new_fd(fileno($file)), $file);
888   }
889   elsif ($input->{data}) {
890     return io_new_buffer($input->{data});
891   }
892   elsif ($input->{callback} || $input->{readcb}) {
893     if ($needseekcb{$type} && !$input->{seekcb}) {
894       $self->_set_error("Format $type needs a seekcb parameter");
895     }
896     if ($input->{maxbuffer}) {
897       return io_new_cb($input->{writecb},
898                        $input->{callback} || $input->{readcb},
899                        $input->{seekcb}, $input->{closecb},
900                        $input->{maxbuffer});
901     }
902     else {
903       return io_new_cb($input->{writecb},
904                        $input->{callback} || $input->{readcb},
905                        $input->{seekcb}, $input->{closecb});
906     }
907   }
908   else {
909     $self->_set_error("file/fd/fh/data/callback parameter missing");
910     return;
911   }
912 }
913
914 sub _get_writer_io {
915   my ($self, $input, $type) = @_;
916
917   if ($input->{fd}) {
918     return io_new_fd($input->{fd});
919   }
920   elsif ($input->{fh}) {
921     my $fd = fileno($input->{fh});
922     unless ($fd) {
923       $self->_set_error("Handle in fh option not opened");
924       return;
925     }
926     return io_new_fd($fd);
927   }
928   elsif ($input->{file}) {
929     my $fh = new IO::File($input->{file},"w+");
930     unless ($fh) { 
931       $self->_set_error("Could not open file $input->{file}: $!");
932       return;
933     }
934     binmode($fh) or die;
935     return (io_new_fd(fileno($fh)), $fh);
936   }
937   elsif ($input->{data}) {
938     return io_new_bufchain();
939   }
940   elsif ($input->{callback} || $input->{writecb}) {
941     if ($input->{maxbuffer}) {
942       return io_new_cb($input->{callback} || $input->{writecb},
943                        $input->{readcb},
944                        $input->{seekcb}, $input->{closecb},
945                        $input->{maxbuffer});
946     }
947     else {
948       return io_new_cb($input->{callback} || $input->{writecb},
949                        $input->{readcb},
950                        $input->{seekcb}, $input->{closecb});
951     }
952   }
953   else {
954     $self->_set_error("file/fd/fh/data/callback parameter missing");
955     return;
956   }
957 }
958
959 # Read an image from file
960
961 sub read {
962   my $self = shift;
963   my %input=@_;
964
965   if (defined($self->{IMG})) {
966     # let IIM_DESTROY do the destruction, since the image may be
967     # referenced from elsewhere
968     #i_img_destroy($self->{IMG});
969     undef($self->{IMG});
970   }
971
972   # FIXME: Find the format here if not specified
973   # yes the code isn't here yet - next week maybe?
974   # Next week?  Are you high or something?  That comment
975   # has been there for half a year dude.
976   # Look, i just work here, ok?
977
978   if (!$input{'type'} and $input{file}) {
979     $input{'type'}=$FORMATGUESS->($input{file});
980   }
981   unless ($input{'type'}) {
982     $self->_set_error('type parameter missing and not possible to guess from extension'); 
983     return undef;
984   }
985   if (!$formats{$input{'type'}}) {
986     $self->{ERRSTR}='format not supported'; return undef;
987   }
988
989   my %iolready=(jpeg=>1, png=>1, tiff=>1, pnm=>1, raw=>1, bmp=>1, tga=>1, rgb=>1, gif=>1);
990
991   if ($iolready{$input{'type'}}) {
992     # Setup data source
993     my ($IO, $fh) = $self->_get_reader_io(\%input, $input{'type'})
994       or return;
995
996     if ( $input{'type'} eq 'jpeg' ) {
997       ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_wiol( $IO );
998       if ( !defined($self->{IMG}) ) {
999         $self->{ERRSTR}='unable to read jpeg image'; return undef;
1000       }
1001       $self->{DEBUG} && print "loading a jpeg file\n";
1002       return $self;
1003     }
1004
1005     if ( $input{'type'} eq 'tiff' ) {
1006       $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1007       if ( !defined($self->{IMG}) ) {
1008         $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1009       }
1010       $self->{DEBUG} && print "loading a tiff file\n";
1011       return $self;
1012     }
1013
1014     if ( $input{'type'} eq 'pnm' ) {
1015       $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1016       if ( !defined($self->{IMG}) ) {
1017         $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
1018       }
1019       $self->{DEBUG} && print "loading a pnm file\n";
1020       return $self;
1021     }
1022
1023     if ( $input{'type'} eq 'png' ) {
1024       $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1025       if ( !defined($self->{IMG}) ) {
1026         $self->{ERRSTR}='unable to read png image';
1027         return undef;
1028       }
1029       $self->{DEBUG} && print "loading a png file\n";
1030     }
1031
1032     if ( $input{'type'} eq 'bmp' ) {
1033       $self->{IMG}=i_readbmp_wiol( $IO );
1034       if ( !defined($self->{IMG}) ) {
1035         $self->{ERRSTR}=$self->_error_as_msg();
1036         return undef;
1037       }
1038       $self->{DEBUG} && print "loading a bmp file\n";
1039     }
1040
1041     if ( $input{'type'} eq 'gif' ) {
1042       if ($input{colors} && !ref($input{colors})) {
1043         # must be a reference to a scalar that accepts the colour map
1044         $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1045         return undef;
1046       }
1047       if ($input{colors}) {
1048         my $colors;
1049         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1050         if ($colors) {
1051           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1052         }
1053       }
1054       else {
1055         $self->{IMG} =i_readgif_wiol( $IO );
1056       }
1057       if ( !defined($self->{IMG}) ) {
1058         $self->{ERRSTR}=$self->_error_as_msg();
1059         return undef;
1060       }
1061       $self->{DEBUG} && print "loading a gif file\n";
1062     }
1063
1064     if ( $input{'type'} eq 'tga' ) {
1065       $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1066       if ( !defined($self->{IMG}) ) {
1067         $self->{ERRSTR}=$self->_error_as_msg();
1068         return undef;
1069       }
1070       $self->{DEBUG} && print "loading a tga file\n";
1071     }
1072
1073     if ( $input{'type'} eq 'rgb' ) {
1074       $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1075       if ( !defined($self->{IMG}) ) {
1076         $self->{ERRSTR}=$self->_error_as_msg();
1077         return undef;
1078       }
1079       $self->{DEBUG} && print "loading a tga file\n";
1080     }
1081
1082
1083     if ( $input{'type'} eq 'raw' ) {
1084       my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1085
1086       if ( !($params{xsize} && $params{ysize}) ) {
1087         $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1088         return undef;
1089       }
1090
1091       $self->{IMG} = i_readraw_wiol( $IO,
1092                                      $params{xsize},
1093                                      $params{ysize},
1094                                      $params{datachannels},
1095                                      $params{storechannels},
1096                                      $params{interleave});
1097       if ( !defined($self->{IMG}) ) {
1098         $self->{ERRSTR}='unable to read raw image';
1099         return undef;
1100       }
1101       $self->{DEBUG} && print "loading a raw file\n";
1102     }
1103
1104   } else {
1105
1106     # Old code for reference while changing the new stuff
1107
1108     if (!$input{'type'} and $input{file}) {
1109       $input{'type'}=$FORMATGUESS->($input{file});
1110     }
1111
1112     if (!$input{'type'}) {
1113       $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef;
1114     }
1115
1116     if (!$formats{$input{'type'}}) {
1117       $self->{ERRSTR}='format not supported';
1118       return undef;
1119     }
1120
1121     my ($fh, $fd);
1122     if ($input{file}) {
1123       $fh = new IO::File($input{file},"r");
1124       if (!defined $fh) {
1125         $self->{ERRSTR}='Could not open file';
1126         return undef;
1127       }
1128       binmode($fh);
1129       $fd = $fh->fileno();
1130     }
1131
1132     if ($input{fd}) {
1133       $fd=$input{fd};
1134     }
1135
1136     if ( $input{'type'} eq 'gif' ) {
1137       my $colors;
1138       if ($input{colors} && !ref($input{colors})) {
1139         # must be a reference to a scalar that accepts the colour map
1140         $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1141         return undef;
1142       }
1143       if (exists $input{data}) {
1144         if ($input{colors}) {
1145           ($self->{IMG}, $colors) = i_readgif_scalar($input{data});
1146         } else {
1147           $self->{IMG}=i_readgif_scalar($input{data});
1148         }
1149       } else {
1150         if ($input{colors}) {
1151           ($self->{IMG}, $colors) = i_readgif( $fd );
1152         } else {
1153           $self->{IMG} = i_readgif( $fd )
1154         }
1155       }
1156       if ($colors) {
1157         # we may or may not change i_readgif to return blessed objects...
1158         ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1159       }
1160       if ( !defined($self->{IMG}) ) {
1161         $self->{ERRSTR}= 'reading GIF:'._error_as_msg();
1162         return undef;
1163       }
1164       $self->{DEBUG} && print "loading a gif file\n";
1165     }
1166   }
1167   return $self;
1168 }
1169
1170 # Write an image to file
1171 sub write {
1172   my $self = shift;
1173   my %input=(jpegquality=>75, 
1174              gifquant=>'mc', 
1175              lmdither=>6.0, 
1176              lmfixed=>[],
1177              idstring=>"",
1178              compress=>1,
1179              wierdpack=>0,
1180              fax_fine=>1, @_);
1181   my $rc;
1182
1183   my %iolready=( tiff=>1, raw=>1, png=>1, pnm=>1, bmp=>1, jpeg=>1, tga=>1, 
1184                  gif=>1 ); # this will be SO MUCH BETTER once they are all in there
1185
1186   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1187
1188   if (!$input{'type'} and $input{file}) { 
1189     $input{'type'}=$FORMATGUESS->($input{file});
1190   }
1191   if (!$input{'type'}) { 
1192     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1193     return undef;
1194   }
1195
1196   if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
1197
1198   my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1199     or return undef;
1200
1201   # this conditional is probably obsolete
1202   if ($iolready{$input{'type'}}) {
1203
1204     if ($input{'type'} eq 'tiff') {
1205       if (defined $input{class} && $input{class} eq 'fax') {
1206         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1207           $self->{ERRSTR}='Could not write to buffer';
1208           return undef;
1209         }
1210       } else {
1211         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1212           $self->{ERRSTR}='Could not write to buffer';
1213           return undef;
1214         }
1215       }
1216     } elsif ( $input{'type'} eq 'pnm' ) {
1217       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1218         $self->{ERRSTR}='unable to write pnm image';
1219         return undef;
1220       }
1221       $self->{DEBUG} && print "writing a pnm file\n";
1222     } elsif ( $input{'type'} eq 'raw' ) {
1223       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1224         $self->{ERRSTR}='unable to write raw image';
1225         return undef;
1226       }
1227       $self->{DEBUG} && print "writing a raw file\n";
1228     } elsif ( $input{'type'} eq 'png' ) {
1229       if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1230         $self->{ERRSTR}='unable to write png image';
1231         return undef;
1232       }
1233       $self->{DEBUG} && print "writing a png file\n";
1234     } elsif ( $input{'type'} eq 'jpeg' ) {
1235       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1236         $self->{ERRSTR} = $self->_error_as_msg();
1237         return undef;
1238       }
1239       $self->{DEBUG} && print "writing a jpeg file\n";
1240     } elsif ( $input{'type'} eq 'bmp' ) {
1241       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1242         $self->{ERRSTR}='unable to write bmp image';
1243         return undef;
1244       }
1245       $self->{DEBUG} && print "writing a bmp file\n";
1246     } elsif ( $input{'type'} eq 'tga' ) {
1247
1248       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1249         $self->{ERRSTR}=$self->_error_as_msg();
1250         return undef;
1251       }
1252       $self->{DEBUG} && print "writing a tga file\n";
1253     } elsif ( $input{'type'} eq 'gif' ) {
1254       # compatibility with the old interfaces
1255       if ($input{gifquant} eq 'lm') {
1256         $input{make_colors} = 'addi';
1257         $input{translate} = 'perturb';
1258         $input{perturb} = $input{lmdither};
1259       } elsif ($input{gifquant} eq 'gen') {
1260         # just pass options through
1261       } else {
1262         $input{make_colors} = 'webmap'; # ignored
1263         $input{translate} = 'giflib';
1264       }
1265       $rc = i_writegif_wiol($IO, \%input, $self->{IMG});
1266     }
1267
1268     if (exists $input{'data'}) {
1269       my $data = io_slurp($IO);
1270       if (!$data) {
1271         $self->{ERRSTR}='Could not slurp from buffer';
1272         return undef;
1273       }
1274       ${$input{data}} = $data;
1275     }
1276     return $self;
1277   }
1278
1279   return $self;
1280 }
1281
1282 sub write_multi {
1283   my ($class, $opts, @images) = @_;
1284
1285   if (!$opts->{'type'} && $opts->{'file'}) {
1286     $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1287   }
1288   unless ($opts->{'type'}) {
1289     $class->_set_error('type parameter missing and not possible to guess from extension');
1290     return;
1291   }
1292   # translate to ImgRaw
1293   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1294     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1295     return 0;
1296   }
1297   my @work = map $_->{IMG}, @images;
1298   my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1299     or return undef;
1300   if ($opts->{'type'} eq 'gif') {
1301     my $gif_delays = $opts->{gif_delays};
1302     local $opts->{gif_delays} = $gif_delays;
1303     if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1304       # assume the caller wants the same delay for each frame
1305       $opts->{gif_delays} = [ ($gif_delays) x @images ];
1306     }
1307     my $res = i_writegif_wiol($IO, $opts, @work);
1308     $res or $class->_set_error($class->_error_as_msg());
1309     return $res;
1310   }
1311   elsif ($opts->{'type'} eq 'tiff') {
1312     my $res;
1313     $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1314     if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1315       $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1316     }
1317     else {
1318       $res = i_writetiff_multi_wiol($IO, @work);
1319     }
1320     $res or $class->_set_error($class->_error_as_msg());
1321     return $res;
1322   }
1323   else {
1324     $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
1325     return 0;
1326   }
1327 }
1328
1329 # read multiple images from a file
1330 sub read_multi {
1331   my ($class, %opts) = @_;
1332
1333   if ($opts{file} && !exists $opts{'type'}) {
1334     # guess the type 
1335     my $type = $FORMATGUESS->($opts{file});
1336     $opts{'type'} = $type;
1337   }
1338   unless ($opts{'type'}) {
1339     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1340     return;
1341   }
1342
1343   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1344     or return;
1345   if ($opts{'type'} eq 'gif') {
1346     my @imgs;
1347     @imgs = i_readgif_multi_wiol($IO);
1348     if (@imgs) {
1349       return map { 
1350         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager' 
1351       } @imgs;
1352     }
1353     else {
1354       $ERRSTR = _error_as_msg();
1355       return;
1356     }
1357   }
1358   elsif ($opts{'type'} eq 'tiff') {
1359     my @imgs = i_readtiff_multi_wiol($IO, -1);
1360     if (@imgs) {
1361       return map { 
1362         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager' 
1363       } @imgs;
1364     }
1365     else {
1366       $ERRSTR = _error_as_msg();
1367       return;
1368     }
1369   }
1370
1371   $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
1372   return;
1373 }
1374
1375 # Destroy an Imager object
1376
1377 sub DESTROY {
1378   my $self=shift;
1379   #    delete $instances{$self};
1380   if (defined($self->{IMG})) {
1381     # the following is now handled by the XS DESTROY method for
1382     # Imager::ImgRaw object
1383     # Re-enabling this will break virtual images
1384     # tested for in t/t020masked.t
1385     # i_img_destroy($self->{IMG});
1386     undef($self->{IMG});
1387   } else {
1388 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1389   }
1390 }
1391
1392 # Perform an inplace filter of an image
1393 # that is the image will be overwritten with the data
1394
1395 sub filter {
1396   my $self=shift;
1397   my %input=@_;
1398   my %hsh;
1399   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1400
1401   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1402
1403   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1404     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1405   }
1406
1407   if ($filters{$input{'type'}}{names}) {
1408     my $names = $filters{$input{'type'}}{names};
1409     for my $name (keys %$names) {
1410       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1411         $input{$name} = $names->{$name}{$input{$name}};
1412       }
1413     }
1414   }
1415   if (defined($filters{$input{'type'}}{defaults})) {
1416     %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
1417   } else {
1418     %hsh=('image',$self->{IMG},%input);
1419   }
1420
1421   my @cs=@{$filters{$input{'type'}}{callseq}};
1422
1423   for(@cs) {
1424     if (!defined($hsh{$_})) {
1425       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1426     }
1427   }
1428
1429   &{$filters{$input{'type'}}{callsub}}(%hsh);
1430
1431   my @b=keys %hsh;
1432
1433   $self->{DEBUG} && print "callseq is: @cs\n";
1434   $self->{DEBUG} && print "matching callseq is: @b\n";
1435
1436   return $self;
1437 }
1438
1439 # Scale an image to requested size and return the scaled version
1440
1441 sub scale {
1442   my $self=shift;
1443   my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
1444   my $img = Imager->new();
1445   my $tmp = Imager->new();
1446
1447   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1448
1449   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
1450     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
1451     if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1452     if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
1453   } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1454   elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1455
1456   if ($opts{qtype} eq 'normal') {
1457     $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1458     if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1459     $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1460     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1461     return $img;
1462   }
1463   if ($opts{'qtype'} eq 'preview') {
1464     $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'}); 
1465     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1466     return $img;
1467   }
1468   $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1469 }
1470
1471 # Scales only along the X axis
1472
1473 sub scaleX {
1474   my $self=shift;
1475   my %opts=(scalefactor=>0.5,@_);
1476
1477   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1478
1479   my $img = Imager->new();
1480
1481   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1482
1483   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1484   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1485
1486   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1487   return $img;
1488 }
1489
1490 # Scales only along the Y axis
1491
1492 sub scaleY {
1493   my $self=shift;
1494   my %opts=(scalefactor=>0.5,@_);
1495
1496   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1497
1498   my $img = Imager->new();
1499
1500   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1501
1502   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1503   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1504
1505   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1506   return $img;
1507 }
1508
1509
1510 # Transform returns a spatial transformation of the input image
1511 # this moves pixels to a new location in the returned image.
1512 # NOTE - should make a utility function to check transforms for
1513 # stack overruns
1514
1515 sub transform {
1516   my $self=shift;
1517   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1518   my %opts=@_;
1519   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1520
1521 #  print Dumper(\%opts);
1522 #  xopcopdes
1523
1524   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1525     if (!$I2P) {
1526       eval ("use Affix::Infix2Postfix;");
1527       print $@;
1528       if ( $@ ) {
1529         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.'; 
1530         return undef;
1531       }
1532       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1533                                              {op=>'-',trans=>'Sub'},
1534                                              {op=>'*',trans=>'Mult'},
1535                                              {op=>'/',trans=>'Div'},
1536                                              {op=>'-','type'=>'unary',trans=>'u-'},
1537                                              {op=>'**'},
1538                                              {op=>'func','type'=>'unary'}],
1539                                      'grouping'=>[qw( \( \) )],
1540                                      'func'=>[qw( sin cos )],
1541                                      'vars'=>[qw( x y )]
1542                                     );
1543     }
1544
1545     @xt=$I2P->translate($opts{'xexpr'});
1546     @yt=$I2P->translate($opts{'yexpr'});
1547
1548     $numre=$I2P->{'numre'};
1549     @pt=(0,0);
1550
1551     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1552     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1553     @{$opts{'parm'}}=@pt;
1554   }
1555
1556 #  print Dumper(\%opts);
1557
1558   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1559     $self->{ERRSTR}='transform: no xopcodes given.';
1560     return undef;
1561   }
1562
1563   @op=@{$opts{'xopcodes'}};
1564   for $iop (@op) { 
1565     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1566       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1567       return undef;
1568     }
1569     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1570   }
1571
1572
1573 # yopcopdes
1574
1575   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1576     $self->{ERRSTR}='transform: no yopcodes given.';
1577     return undef;
1578   }
1579
1580   @op=@{$opts{'yopcodes'}};
1581   for $iop (@op) { 
1582     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1583       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1584       return undef;
1585     }
1586     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1587   }
1588
1589 #parameters
1590
1591   if ( !exists $opts{'parm'}) {
1592     $self->{ERRSTR}='transform: no parameter arg given.';
1593     return undef;
1594   }
1595
1596 #  print Dumper(\@ropx);
1597 #  print Dumper(\@ropy);
1598 #  print Dumper(\@ropy);
1599
1600   my $img = Imager->new();
1601   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1602   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1603   return $img;
1604 }
1605
1606
1607 sub transform2 {
1608   my ($opts, @imgs) = @_;
1609   
1610   require "Imager/Expr.pm";
1611
1612   $opts->{variables} = [ qw(x y) ];
1613   my ($width, $height) = @{$opts}{qw(width height)};
1614   if (@imgs) {
1615     $width ||= $imgs[0]->getwidth();
1616     $height ||= $imgs[0]->getheight();
1617     my $img_num = 1;
1618     for my $img (@imgs) {
1619       $opts->{constants}{"w$img_num"} = $img->getwidth();
1620       $opts->{constants}{"h$img_num"} = $img->getheight();
1621       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1622       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1623       ++$img_num;
1624     }
1625   }
1626   if ($width) {
1627     $opts->{constants}{w} = $width;
1628     $opts->{constants}{cx} = $width/2;
1629   }
1630   else {
1631     $Imager::ERRSTR = "No width supplied";
1632     return;
1633   }
1634   if ($height) {
1635     $opts->{constants}{h} = $height;
1636     $opts->{constants}{cy} = $height/2;
1637   }
1638   else {
1639     $Imager::ERRSTR = "No height supplied";
1640     return;
1641   }
1642   my $code = Imager::Expr->new($opts);
1643   if (!$code) {
1644     $Imager::ERRSTR = Imager::Expr::error();
1645     return;
1646   }
1647
1648   my $img = Imager->new();
1649   $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, $code->code(),
1650                              $code->nregs(), $code->cregs(),
1651                              [ map { $_->{IMG} } @imgs ]);
1652   if (!defined $img->{IMG}) {
1653     $Imager::ERRSTR = Imager->_error_as_msg();
1654     return;
1655   }
1656
1657   return $img;
1658 }
1659
1660 sub rubthrough {
1661   my $self=shift;
1662   my %opts=(tx=>0,ty=>0,@_);
1663
1664   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1665   unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1666
1667   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx},$opts{ty})) {
1668     $self->{ERRSTR} = $self->_error_as_msg();
1669     return undef;
1670   }
1671   return $self;
1672 }
1673
1674
1675 sub flip {
1676   my $self  = shift;
1677   my %opts  = @_;
1678   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
1679   my $dir;
1680   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1681   $dir = $xlate{$opts{'dir'}};
1682   return $self if i_flipxy($self->{IMG}, $dir);
1683   return ();
1684 }
1685
1686 sub rotate {
1687   my $self = shift;
1688   my %opts = @_;
1689   if (defined $opts{right}) {
1690     my $degrees = $opts{right};
1691     if ($degrees < 0) {
1692       $degrees += 360 * int(((-$degrees)+360)/360);
1693     }
1694     $degrees = $degrees % 360;
1695     if ($degrees == 0) {
1696       return $self->copy();
1697     }
1698     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1699       my $result = Imager->new();
1700       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1701         return $result;
1702       }
1703       else {
1704         $self->{ERRSTR} = $self->_error_as_msg();
1705         return undef;
1706       }
1707     }
1708     else {
1709       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1710       return undef;
1711     }
1712   }
1713   elsif (defined $opts{radians} || defined $opts{degrees}) {
1714     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1715
1716     my $result = Imager->new;
1717     if ($result->{IMG} = i_rotate_exact($self->{IMG}, $amount)) {
1718       return $result;
1719     }
1720     else {
1721       $self->{ERRSTR} = $self->_error_as_msg();
1722       return undef;
1723     }
1724   }
1725   else {
1726     $self->{ERRSTR} = "Only the 'right' parameter is available";
1727     return undef;
1728   }
1729 }
1730
1731 sub matrix_transform {
1732   my $self = shift;
1733   my %opts = @_;
1734
1735   if ($opts{matrix}) {
1736     my $xsize = $opts{xsize} || $self->getwidth;
1737     my $ysize = $opts{ysize} || $self->getheight;
1738
1739     my $result = Imager->new;
1740     $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize, 
1741                                         $opts{matrix})
1742       or return undef;
1743
1744     return $result;
1745   }
1746   else {
1747     $self->{ERRSTR} = "matrix parameter required";
1748     return undef;
1749   }
1750 }
1751
1752 # blame Leolo :)
1753 *yatf = \&matrix_transform;
1754
1755 # These two are supported for legacy code only
1756
1757 sub i_color_new {
1758   return Imager::Color->new(@_);
1759 }
1760
1761 sub i_color_set {
1762   return Imager::Color::set(@_);
1763 }
1764
1765 # Draws a box between the specified corner points.
1766 sub box {
1767   my $self=shift;
1768   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1769   my $dflcl=i_color_new(255,255,255,255);
1770   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1771
1772   if (exists $opts{'box'}) { 
1773     $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1774     $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1775     $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1776     $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1777   }
1778
1779   if ($opts{filled}) { 
1780     my $color = _color($opts{'color'});
1781     unless ($color) { 
1782       $self->{ERRSTR} = $Imager::ERRSTR; 
1783       return; 
1784     }
1785     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1786                  $opts{ymax}, $color); 
1787   }
1788   elsif ($opts{fill}) {
1789     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1790       # assume it's a hash ref
1791       require 'Imager/Fill.pm';
1792       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1793         $self->{ERRSTR} = $Imager::ERRSTR;
1794         return undef;
1795       }
1796     }
1797     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1798                 $opts{ymax},$opts{fill}{fill});
1799   }
1800   else {
1801     my $color = _color($opts{'color'});
1802     unless ($color) { 
1803       $self->{ERRSTR} = $Imager::ERRSTR;
1804       return;
1805     }
1806     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
1807           $color);
1808   }
1809   return $self;
1810 }
1811
1812 # Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
1813
1814 sub arc {
1815   my $self=shift;
1816   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1817   my $dflcl=i_color_new(255,255,255,255);
1818   my %opts=(color=>$dflcl,
1819             'r'=>min($self->getwidth(),$self->getheight())/3,
1820             'x'=>$self->getwidth()/2,
1821             'y'=>$self->getheight()/2,
1822             'd1'=>0, 'd2'=>361, @_);
1823   if ($opts{fill}) {
1824     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1825       # assume it's a hash ref
1826       require 'Imager/Fill.pm';
1827       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1828         $self->{ERRSTR} = $Imager::ERRSTR;
1829         return;
1830       }
1831     }
1832     i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
1833                 $opts{'d2'}, $opts{fill}{fill});
1834   }
1835   else {
1836     my $color = _color($opts{'color'});
1837     unless ($color) { 
1838       $self->{ERRSTR} = $Imager::ERRSTR; 
1839       return; 
1840     }
1841     if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
1842       i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, 
1843                   $color);
1844     }
1845     else {
1846       if ($opts{'d1'} <= $opts{'d2'}) { 
1847         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1848               $opts{'d1'}, $opts{'d2'}, $color); 
1849       }
1850       else {
1851         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1852               $opts{'d1'}, 361,         $color);
1853         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1854               0,           $opts{'d2'}, $color); 
1855       }
1856     }
1857   }
1858
1859   return $self;
1860 }
1861
1862 # Draws a line from one point to (but not including) the destination point
1863
1864 sub line {
1865   my $self=shift;
1866   my $dflcl=i_color_new(0,0,0,0);
1867   my %opts=(color=>$dflcl,@_);
1868   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1869
1870   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
1871   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
1872
1873   my $color = _color($opts{'color'});
1874   unless ($color) { 
1875     $self->{ERRSTR} = $Imager::ERRSTR; 
1876     return; 
1877   }
1878   $opts{antialias} = $opts{aa} if defined $opts{aa};
1879   if ($opts{antialias}) {
1880     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2}, 
1881               $color);
1882   } else {
1883     i_draw($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2}, 
1884            $color);
1885   }
1886   return $self;
1887 }
1888
1889 # Draws a line between an ordered set of points - It more or less just transforms this
1890 # into a list of lines.
1891
1892 sub polyline {
1893   my $self=shift;
1894   my ($pt,$ls,@points);
1895   my $dflcl=i_color_new(0,0,0,0);
1896   my %opts=(color=>$dflcl,@_);
1897
1898   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1899
1900   if (exists($opts{points})) { @points=@{$opts{points}}; }
1901   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
1902     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
1903     }
1904
1905 #  print Dumper(\@points);
1906
1907   my $color = _color($opts{'color'});
1908   unless ($color) { 
1909     $self->{ERRSTR} = $Imager::ERRSTR; 
1910     return; 
1911   }
1912   $opts{antialias} = $opts{aa} if defined $opts{aa};
1913   if ($opts{antialias}) {
1914     for $pt(@points) {
1915       if (defined($ls)) { 
1916         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
1917       }
1918       $ls=$pt;
1919     }
1920   } else {
1921     for $pt(@points) {
1922       if (defined($ls)) { 
1923         i_draw($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
1924       }
1925       $ls=$pt;
1926     }
1927   }
1928   return $self;
1929 }
1930
1931 sub polygon {
1932   my $self = shift;
1933   my ($pt,$ls,@points);
1934   my $dflcl = i_color_new(0,0,0,0);
1935   my %opts = (color=>$dflcl, @_);
1936
1937   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1938
1939   if (exists($opts{points})) {
1940     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
1941     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
1942   }
1943
1944   if (!exists $opts{'x'} or !exists $opts{'y'})  {
1945     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
1946   }
1947
1948   if ($opts{'fill'}) {
1949     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
1950       # assume it's a hash ref
1951       require 'Imager/Fill.pm';
1952       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
1953         $self->{ERRSTR} = $Imager::ERRSTR;
1954         return undef;
1955       }
1956     }
1957     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, 
1958                     $opts{'fill'}{'fill'});
1959   }
1960   else {
1961     my $color = _color($opts{'color'});
1962     unless ($color) { 
1963       $self->{ERRSTR} = $Imager::ERRSTR; 
1964       return; 
1965     }
1966     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
1967   }
1968
1969   return $self;
1970 }
1971
1972
1973 # this the multipoint bezier curve
1974 # this is here more for testing that actual usage since
1975 # this is not a good algorithm.  Usually the curve would be
1976 # broken into smaller segments and each done individually.
1977
1978 sub polybezier {
1979   my $self=shift;
1980   my ($pt,$ls,@points);
1981   my $dflcl=i_color_new(0,0,0,0);
1982   my %opts=(color=>$dflcl,@_);
1983
1984   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1985
1986   if (exists $opts{points}) {
1987     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
1988     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
1989   }
1990
1991   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
1992     $self->{ERRSTR}='Missing or invalid points.';
1993     return;
1994   }
1995
1996   my $color = _color($opts{'color'});
1997   unless ($color) { 
1998     $self->{ERRSTR} = $Imager::ERRSTR; 
1999     return; 
2000   }
2001   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2002   return $self;
2003 }
2004
2005 sub flood_fill {
2006   my $self = shift;
2007   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2008
2009   unless (exists $opts{'x'} && exists $opts{'y'}) {
2010     $self->{ERRSTR} = "missing seed x and y parameters";
2011     return undef;
2012   }
2013
2014   if ($opts{fill}) {
2015     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2016       # assume it's a hash ref
2017       require 'Imager/Fill.pm';
2018       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2019         $self->{ERRSTR} = $Imager::ERRSTR;
2020         return;
2021       }
2022     }
2023     i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2024   }
2025   else {
2026     my $color = _color($opts{'color'});
2027     unless ($color) { 
2028       $self->{ERRSTR} = $Imager::ERRSTR; 
2029       return; 
2030     }
2031     i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2032   }
2033
2034   $self;
2035 }
2036
2037 sub setpixel {
2038   my $self = shift;
2039
2040   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2041
2042   unless (exists $opts{'x'} && exists $opts{'y'}) {
2043     $self->{ERRSTR} = 'missing x and y parameters';
2044     return undef;
2045   }
2046
2047   my $x = $opts{'x'};
2048   my $y = $opts{'y'};
2049   my $color = _color($opts{color})
2050     or return undef;
2051   if (ref $x && ref $y) {
2052     unless (@$x == @$y) {
2053       $self->{ERRSTR} = 'length of x and y mistmatch';
2054       return undef;
2055     }
2056     if ($color->isa('Imager::Color')) {
2057       for my $i (0..$#{$opts{'x'}}) {
2058         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2059       }
2060     }
2061     else {
2062       for my $i (0..$#{$opts{'x'}}) {
2063         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2064       }
2065     }
2066   }
2067   else {
2068     if ($color->isa('Imager::Color')) {
2069       i_ppix($self->{IMG}, $x, $y, $color);
2070     }
2071     else {
2072       i_ppixf($self->{IMG}, $x, $y, $color);
2073     }
2074   }
2075
2076   $self;
2077 }
2078
2079 sub getpixel {
2080   my $self = shift;
2081
2082   my %opts = ( type=>'8bit', @_);
2083
2084   unless (exists $opts{'x'} && exists $opts{'y'}) {
2085     $self->{ERRSTR} = 'missing x and y parameters';
2086     return undef;
2087   }
2088
2089   my $x = $opts{'x'};
2090   my $y = $opts{'y'};
2091   if (ref $x && ref $y) {
2092     unless (@$x == @$y) {
2093       $self->{ERRSTR} = 'length of x and y mismatch';
2094       return undef;
2095     }
2096     my @result;
2097     if ($opts{type} eq '8bit') {
2098       for my $i (0..$#{$opts{'x'}}) {
2099         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2100       }
2101     }
2102     else {
2103       for my $i (0..$#{$opts{'x'}}) {
2104         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2105       }
2106     }
2107     return wantarray ? @result : \@result;
2108   }
2109   else {
2110     if ($opts{type} eq '8bit') {
2111       return i_get_pixel($self->{IMG}, $x, $y);
2112     }
2113     else {
2114       return i_gpixf($self->{IMG}, $x, $y);
2115     }
2116   }
2117
2118   $self;
2119 }
2120
2121 # make an identity matrix of the given size
2122 sub _identity {
2123   my ($size) = @_;
2124
2125   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2126   for my $c (0 .. ($size-1)) {
2127     $matrix->[$c][$c] = 1;
2128   }
2129   return $matrix;
2130 }
2131
2132 # general function to convert an image
2133 sub convert {
2134   my ($self, %opts) = @_;
2135   my $matrix;
2136
2137   # the user can either specify a matrix or preset
2138   # the matrix overrides the preset
2139   if (!exists($opts{matrix})) {
2140     unless (exists($opts{preset})) {
2141       $self->{ERRSTR} = "convert() needs a matrix or preset";
2142       return;
2143     }
2144     else {
2145       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2146         # convert to greyscale, keeping the alpha channel if any
2147         if ($self->getchannels == 3) {
2148           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2149         }
2150         elsif ($self->getchannels == 4) {
2151           # preserve the alpha channel
2152           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2153                       [ 0,     0,     0,     1 ] ];
2154         }
2155         else {
2156           # an identity
2157           $matrix = _identity($self->getchannels);
2158         }
2159       }
2160       elsif ($opts{preset} eq 'noalpha') {
2161         # strip the alpha channel
2162         if ($self->getchannels == 2 or $self->getchannels == 4) {
2163           $matrix = _identity($self->getchannels);
2164           pop(@$matrix); # lose the alpha entry
2165         }
2166         else {
2167           $matrix = _identity($self->getchannels);
2168         }
2169       }
2170       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2171         # extract channel 0
2172         $matrix = [ [ 1 ] ];
2173       }
2174       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2175         $matrix = [ [ 0, 1 ] ];
2176       }
2177       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2178         $matrix = [ [ 0, 0, 1 ] ];
2179       }
2180       elsif ($opts{preset} eq 'alpha') {
2181         if ($self->getchannels == 2 or $self->getchannels == 4) {
2182           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2183         }
2184         else {
2185           # the alpha is just 1 <shrug>
2186           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2187         }
2188       }
2189       elsif ($opts{preset} eq 'rgb') {
2190         if ($self->getchannels == 1) {
2191           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2192         }
2193         elsif ($self->getchannels == 2) {
2194           # preserve the alpha channel
2195           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2196         }
2197         else {
2198           $matrix = _identity($self->getchannels);
2199         }
2200       }
2201       elsif ($opts{preset} eq 'addalpha') {
2202         if ($self->getchannels == 1) {
2203           $matrix = _identity(2);
2204         }
2205         elsif ($self->getchannels == 3) {
2206           $matrix = _identity(4);
2207         }
2208         else {
2209           $matrix = _identity($self->getchannels);
2210         }
2211       }
2212       else {
2213         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2214         return undef;
2215       }
2216     }
2217   }
2218   else {
2219     $matrix = $opts{matrix};
2220   }
2221
2222   my $new = Imager->new();
2223   $new->{IMG} = i_img_new();
2224   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2225     # most likely a bad matrix
2226     $self->{ERRSTR} = _error_as_msg();
2227     return undef;
2228   }
2229   return $new;
2230 }
2231
2232
2233 # general function to map an image through lookup tables
2234
2235 sub map {
2236   my ($self, %opts) = @_;
2237   my @chlist = qw( red green blue alpha );
2238
2239   if (!exists($opts{'maps'})) {
2240     # make maps from channel maps
2241     my $chnum;
2242     for $chnum (0..$#chlist) {
2243       if (exists $opts{$chlist[$chnum]}) {
2244         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2245       } elsif (exists $opts{'all'}) {
2246         $opts{'maps'}[$chnum] = $opts{'all'};
2247       }
2248     }
2249   }
2250   if ($opts{'maps'} and $self->{IMG}) {
2251     i_map($self->{IMG}, $opts{'maps'} );
2252   }
2253   return $self;
2254 }
2255
2256 # destructive border - image is shrunk by one pixel all around
2257
2258 sub border {
2259   my ($self,%opts)=@_;
2260   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2261   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2262 }
2263
2264
2265 # Get the width of an image
2266
2267 sub getwidth {
2268   my $self = shift;
2269   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2270   return (i_img_info($self->{IMG}))[0];
2271 }
2272
2273 # Get the height of an image
2274
2275 sub getheight {
2276   my $self = shift;
2277   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2278   return (i_img_info($self->{IMG}))[1];
2279 }
2280
2281 # Get number of channels in an image
2282
2283 sub getchannels {
2284   my $self = shift;
2285   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2286   return i_img_getchannels($self->{IMG});
2287 }
2288
2289 # Get channel mask
2290
2291 sub getmask {
2292   my $self = shift;
2293   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2294   return i_img_getmask($self->{IMG});
2295 }
2296
2297 # Set channel mask
2298
2299 sub setmask {
2300   my $self = shift;
2301   my %opts = @_;
2302   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2303   i_img_setmask( $self->{IMG} , $opts{mask} );
2304 }
2305
2306 # Get number of colors in an image
2307
2308 sub getcolorcount {
2309   my $self=shift;
2310   my %opts=('maxcolors'=>2**30,@_);
2311   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2312   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2313   return ($rc==-1? undef : $rc);
2314 }
2315
2316 # draw string to an image
2317
2318 sub string {
2319   my $self = shift;
2320   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2321
2322   my %input=('x'=>0, 'y'=>0, @_);
2323   $input{string}||=$input{text};
2324
2325   unless(exists $input{string}) {
2326     $self->{ERRSTR}="missing required parameter 'string'";
2327     return;
2328   }
2329
2330   unless($input{font}) {
2331     $self->{ERRSTR}="missing required parameter 'font'";
2332     return;
2333   }
2334
2335   unless ($input{font}->draw(image=>$self, %input)) {
2336     $self->{ERRSTR} = $self->_error_as_msg();
2337     return;
2338   }
2339
2340   return $self;
2341 }
2342
2343 # Shortcuts that can be exported
2344
2345 sub newcolor { Imager::Color->new(@_); }
2346 sub newfont  { Imager::Font->new(@_); }
2347
2348 *NC=*newcolour=*newcolor;
2349 *NF=*newfont;
2350
2351 *open=\&read;
2352 *circle=\&arc;
2353
2354
2355 #### Utility routines
2356
2357 sub errstr { 
2358   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2359 }
2360
2361 sub _set_error {
2362   my ($self, $msg) = @_;
2363
2364   if (ref $self) {
2365     $self->{ERRSTR} = $msg;
2366   }
2367   else {
2368     $ERRSTR = $msg;
2369   }
2370 }
2371
2372 # Default guess for the type of an image from extension
2373
2374 sub def_guess_type {
2375   my $name=lc(shift);
2376   my $ext;
2377   $ext=($name =~ m/\.([^\.]+)$/)[0];
2378   return 'tiff' if ($ext =~ m/^tiff?$/);
2379   return 'jpeg' if ($ext =~ m/^jpe?g$/);
2380   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
2381   return 'png'  if ($ext eq "png");
2382   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
2383   return 'tga'  if ($ext eq "tga");
2384   return 'rgb'  if ($ext eq "rgb");
2385   return 'gif'  if ($ext eq "gif");
2386   return 'raw'  if ($ext eq "raw");
2387   return ();
2388 }
2389
2390 # get the minimum of a list
2391
2392 sub min {
2393   my $mx=shift;
2394   for(@_) { if ($_<$mx) { $mx=$_; }}
2395   return $mx;
2396 }
2397
2398 # get the maximum of a list
2399
2400 sub max {
2401   my $mx=shift;
2402   for(@_) { if ($_>$mx) { $mx=$_; }}
2403   return $mx;
2404 }
2405
2406 # string stuff for iptc headers
2407
2408 sub clean {
2409   my($str)=$_[0];
2410   $str = substr($str,3);
2411   $str =~ s/[\n\r]//g;
2412   $str =~ s/\s+/ /g;
2413   $str =~ s/^\s//;
2414   $str =~ s/\s$//;
2415   return $str;
2416 }
2417
2418 # A little hack to parse iptc headers.
2419
2420 sub parseiptc {
2421   my $self=shift;
2422   my(@sar,$item,@ar);
2423   my($caption,$photogr,$headln,$credit);
2424
2425   my $str=$self->{IPTCRAW};
2426
2427   #print $str;
2428
2429   @ar=split(/8BIM/,$str);
2430
2431   my $i=0;
2432   foreach (@ar) {
2433     if (/^\004\004/) {
2434       @sar=split(/\034\002/);
2435       foreach $item (@sar) {
2436         if ($item =~ m/^x/) {
2437           $caption=&clean($item);
2438           $i++;
2439         }
2440         if ($item =~ m/^P/) {
2441           $photogr=&clean($item);
2442           $i++;
2443         }
2444         if ($item =~ m/^i/) {
2445           $headln=&clean($item);
2446           $i++;
2447         }
2448         if ($item =~ m/^n/) {
2449           $credit=&clean($item);
2450           $i++;
2451         }
2452       }
2453     }
2454   }
2455   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2456 }
2457
2458 # Autoload methods go after =cut, and are processed by the autosplit program.
2459
2460 1;
2461 __END__
2462 # Below is the stub of documentation for your module. You better edit it!
2463
2464 =head1 NAME
2465
2466 Imager - Perl extension for Generating 24 bit Images
2467
2468 =head1 SYNOPSIS
2469
2470   # Thumbnail example
2471
2472   #!/usr/bin/perl -w
2473   use strict;
2474   use Imager;
2475
2476   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2477   my $file = shift;
2478
2479   my $format;
2480
2481   my $img = Imager->new();
2482   $img->open(file=>$file) or die $img->errstr();
2483
2484   $file =~ s/\.[^.]*$//;
2485
2486   # Create smaller version
2487   my $thumb = $img->scale(scalefactor=>.3);
2488
2489   # Autostretch individual channels
2490   $thumb->filter(type=>'autolevels');
2491
2492   # try to save in one of these formats
2493   SAVE:
2494
2495   for $format ( qw( png gif jpg tiff ppm ) ) {
2496     # Check if given format is supported
2497     if ($Imager::formats{$format}) {
2498       $file.="_low.$format";
2499       print "Storing image as: $file\n";
2500       $thumb->write(file=>$file) or
2501         die $thumb->errstr;
2502       last SAVE;
2503     }
2504   }
2505
2506
2507   # Logo Generator Example
2508
2509
2510
2511 =head1 DESCRIPTION
2512
2513 Imager is a module for creating and altering images.  It can read and
2514 write various image formats, draw primitive shapes like lines,and
2515 polygons, blend multiple images together in various ways, scale, crop,
2516 render text and more.
2517
2518 =head2 Overview of documentation
2519
2520 =over
2521
2522 =item Imager
2523
2524 This document - Synopsis Example, Table of Contents and Overview.
2525
2526 =item Imager::ImageTypes
2527
2528 Direct type/virtual images, RGB(A)/paletted images, 8/16/double
2529 bits/channel, color maps, channel masks, image tags, color
2530 quantization.
2531
2532 =item Imager::Files
2533
2534 IO interaction, reading/writing images, format specific tags.
2535
2536 =item Imager::Draw
2537
2538 Drawing Primitives, lines, boxes, circles, arcs, flood fill.
2539
2540 =item Imager::Color
2541
2542 Color specification.
2543
2544 =item Imager::Fill
2545
2546 Fill pattern specification.
2547
2548 =item Imager::Font
2549
2550 General font rendering, bounding boxes and font metrics.
2551
2552 =item Imager::Transformations
2553
2554 Copying, scaling, cropping, flipping, blending, pasting, convert and
2555 map.
2556
2557 =item Imager::Engines
2558
2559 Programmable transformations through C<transform()>, C<transform2()>
2560 and C<matrix_transform()>.
2561
2562 =item Imager::Filters
2563
2564 Filters, sharpen, blur, noise, convolve etc. and filter plugins.
2565
2566 =item Imager::Expr
2567
2568 Expressions for evaluation engine used by transform2().
2569
2570 =item Imager::Matrix2d
2571
2572 Helper class for affine transformations.
2573
2574 =item Imager::Fountain
2575
2576 Helper for making gradient profiles.
2577
2578 =back
2579
2580
2581
2582 =head2 Basic Overview
2583
2584 An Image object is created with C<$img = Imager-E<gt>new()> Should
2585 this fail for some reason an explanation can be found in
2586 C<$Imager::ERRSTR> usually error messages are stored in
2587 C<$img-E<gt>{ERRSTR}>, but since no object is created this is the only
2588 way to give back errors.  C<$Imager::ERRSTR> is also used to report
2589 all errors not directly associated with an image object. Examples:
2590
2591   $img=Imager->new(); # This is an empty image (size is 0 by 0)
2592   $img->open(file=>'lena.png',type=>'png'); # initializes from file
2593
2594 or if you want to create an empty image:
2595
2596   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2597
2598 This example creates a completely black image of width 400 and height
2599 300 and 4 channels.
2600
2601 =head1 SUPPORT
2602
2603 You can ask for help, report bugs or express your undying love for
2604 Imager on the Imager-devel mailing list.
2605
2606 To subscribe send a message with C<subscribe> in the body to:
2607
2608    imager-devel+request@molar.is
2609
2610 or use the form at:
2611
2612    http://www.molar.is/en/lists/imager-devel/
2613
2614 where you can also find the mailing list archive.
2615
2616 If you're into IRC, you can typically find the developers in #Imager
2617 on irc.rhizomatic.net.  As with any IRC channel, the participants
2618 could be occupied or asleep, so please be patient.
2619
2620 =head1 BUGS
2621
2622 Bugs are listed individually for relevant pod pages.
2623
2624 =head1 AUTHOR
2625
2626 Arnar M. Hrafnkelsson (addi@umich.edu) and Tony Cook
2627 (tony@imager.perl.org) See the README for a complete list.
2628
2629 =head1 SEE ALSO
2630
2631 perl(1), Imager::Color(3), Imager::Font(3), Imager::Matrix2d(3),
2632
2633 Affix::Infix2Postfix(3), Parse::RecDescent(3)
2634 http://www.eecs.umich.edu/~addi/perl/Imager/
2635
2636 =cut