eliminate use vars
[imager.git] / Imager.pm
1 package Imager;
2 use 5.006;
3
4 use strict;
5 use IO::File;
6 use Scalar::Util;
7 use Imager::Color;
8 use Imager::Font;
9 use Config;
10
11 our $ERRSTR;
12
13 our @EXPORT_OK = qw(
14                 init
15                 init_log
16                 DSO_open
17                 DSO_close
18                 DSO_funclist
19                 DSO_call
20
21                 load_plugin
22                 unload_plugin
23
24                 i_list_formats
25
26                 i_color_new
27                 i_color_set
28                 i_color_info
29
30                 i_img_info
31
32                 i_img_setmask
33                 i_img_getmask
34
35                 i_line
36                 i_line_aa
37                 i_box
38                 i_box_filled
39                 i_arc
40                 i_circle_aa
41
42                 i_bezier_multi
43                 i_poly_aa
44                 i_poly_aa_cfill
45
46                 i_copyto
47                 i_rubthru
48                 i_scaleaxis
49                 i_scale_nn
50                 i_haar
51                 i_count_colors
52
53                 i_gaussian
54                 i_conv
55
56                 i_convert
57                 i_map
58
59                 i_img_diff
60
61                 i_tt_set_aa
62                 i_tt_cp
63                 i_tt_text
64                 i_tt_bbox
65
66                 i_readpnm_wiol
67                 i_writeppm_wiol
68
69                 i_readraw_wiol
70                 i_writeraw_wiol
71
72                 i_contrast
73                 i_hardinvert
74                 i_noise
75                 i_bumpmap
76                 i_postlevels
77                 i_mosaic
78                 i_watermark
79
80                 malloc_state
81
82                 list_formats
83
84                 i_gifquant
85
86                 newfont
87                 newcolor
88                 newcolour
89                 NC
90                 NF
91                 NCF
92 );
93
94 our @EXPORT=qw(
95           );
96
97 our %EXPORT_TAGS=
98   (handy => [qw(
99                 newfont
100                 newcolor
101                 NF
102                 NC
103                 NCF
104                )],
105    all => [@EXPORT_OK],
106    default => [qw(
107                   load_plugin
108                   unload_plugin
109                  )]);
110
111 # registered file readers
112 my %readers;
113
114 # registered file writers
115 my %writers;
116
117 # modules we attempted to autoload
118 my %attempted_to_load;
119
120 # errors from loading files
121 my %file_load_errors;
122
123 # what happened when we tried to load
124 my %reader_load_errors;
125 my %writer_load_errors;
126
127 # library keys that are image file formats
128 my %file_formats = map { $_ => 1 } qw/tiff pnm gif png jpeg raw bmp tga/;
129
130 # image pixel combine types
131 my @combine_types = 
132   qw/none normal multiply dissolve add subtract diff lighten darken
133      hue saturation value color/;
134 my %combine_types;
135 @combine_types{@combine_types} = 0 .. $#combine_types;
136 $combine_types{mult} = $combine_types{multiply};
137 $combine_types{'sub'}  = $combine_types{subtract};
138 $combine_types{sat}  = $combine_types{saturation};
139
140 # this will be used to store global defaults at some point
141 my %defaults;
142
143 our $VERSION;
144
145 BEGIN {
146   require Exporter;
147   my $ex_version = eval $Exporter::VERSION;
148   if ($ex_version < 5.57) {
149     our @ISA = qw(Exporter);
150   }
151   $VERSION = '1.011';
152   require XSLoader;
153   XSLoader::load(Imager => $VERSION);
154 }
155
156 my %formats_low;
157 my %format_classes =
158   (
159    png => "Imager::File::PNG",
160    gif => "Imager::File::GIF",
161    tiff => "Imager::File::TIFF",
162    jpeg => "Imager::File::JPEG",
163    w32 => "Imager::Font::W32",
164    ft2 => "Imager::Font::FT2",
165    t1 => "Imager::Font::T1",
166   );
167
168 our %formats;
169
170 tie %formats, "Imager::FORMATS", \%formats_low, \%format_classes;
171
172 our %filters;
173
174 our $DEBUG;
175 our %OPCODES;
176 our $FORMATGUESS;
177 our $warn_obsolete;
178
179 BEGIN {
180   for(i_list_formats()) { $formats_low{$_}++; }
181
182   %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
183
184   $DEBUG=0;
185
186   # the members of the subhashes under %filters are:
187   #  callseq - a list of the parameters to the underlying filter in the
188   #            order they are passed
189   #  callsub - a code ref that takes a named parameter list and calls the
190   #            underlying filter
191   #  defaults - a hash of default values
192   #  names - defines names for value of given parameters so if the names 
193   #          field is foo=> { bar=>1 }, and the user supplies "bar" as the
194   #          foo parameter, the filter will receive 1 for the foo
195   #          parameter
196   $filters{contrast}={
197                       callseq => ['image','intensity'],
198                       callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); } 
199                      };
200
201   $filters{noise} ={
202                     callseq => ['image', 'amount', 'subtype'],
203                     defaults => { amount=>3,subtype=>0 },
204                     callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
205                    };
206
207   $filters{hardinvert} ={
208                          callseq => ['image'],
209                          defaults => { },
210                          callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
211                         };
212
213   $filters{hardinvertall} =
214     {
215      callseq => ['image'],
216      defaults => { },
217      callsub => sub { my %hsh=@_; i_hardinvertall($hsh{image}); }
218     };
219
220   $filters{autolevels_skew} ={
221                          callseq => ['image','lsat','usat','skew'],
222                          defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
223                          callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
224                         };
225
226   $filters{autolevels} ={
227                          callseq => ['image','lsat','usat'],
228                          defaults => { lsat=>0.1,usat=>0.1 },
229                          callsub => sub { my %hsh=@_; i_autolevels_mono($hsh{image},$hsh{lsat},$hsh{usat}); }
230                         };
231
232   $filters{turbnoise} ={
233                         callseq => ['image'],
234                         defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
235                         callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
236                        };
237
238   $filters{radnoise} ={
239                        callseq => ['image'],
240                        defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
241                        callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
242                       };
243
244   $filters{conv} =
245     {
246      callseq => ['image', 'coef'],
247      defaults => { },
248      callsub => 
249      sub { 
250        my %hsh=@_;
251        i_conv($hsh{image},$hsh{coef})
252          or die Imager->_error_as_msg() . "\n";
253      }
254     };
255
256   $filters{gradgen} =
257     {
258      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
259      defaults => { dist => 0 },
260      callsub => 
261      sub { 
262        my %hsh=@_;
263        my @colors = @{$hsh{colors}};
264        $_ = _color($_)
265          for @colors;
266        i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
267      }
268     };
269
270   $filters{nearest_color} =
271     {
272      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
273      defaults => { },
274      callsub => 
275      sub { 
276        my %hsh=@_; 
277        # make sure the segments are specified with colors
278        my @colors;
279        for my $color (@{$hsh{colors}}) {
280          my $new_color = _color($color) 
281            or die $Imager::ERRSTR."\n";
282          push @colors, $new_color;
283        }
284
285        i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, 
286                        $hsh{dist})
287          or die Imager->_error_as_msg() . "\n";
288      },
289     };
290   $filters{gaussian} = {
291                         callseq => [ 'image', 'stddev' ],
292                         defaults => { },
293                         callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
294                        };
295   $filters{gaussian2} = {
296                         callseq => [ 'image', 'stddevX', 'stddevY' ],
297                         defaults => { },
298                         callsub => sub { my %hsh = @_; i_gaussian2($hsh{image}, $hsh{stddevX}, $hsh{stddevY}); },
299                        };
300   $filters{mosaic} =
301     {
302      callseq => [ qw(image size) ],
303      defaults => { size => 20 },
304      callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
305     };
306   $filters{bumpmap} =
307     {
308      callseq => [ qw(image bump elevation lightx lighty st) ],
309      defaults => { elevation=>0, st=> 2 },
310      callsub => sub {
311        my %hsh = @_;
312        i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
313                  $hsh{lightx}, $hsh{lighty}, $hsh{st});
314      },
315     };
316   $filters{bumpmap_complex} =
317     {
318      callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
319      defaults => {
320                   channel => 0,
321                   tx => 0,
322                   ty => 0,
323                   Lx => 0.2,
324                   Ly => 0.4,
325                   Lz => -1.0,
326                   cd => 1.0,
327                   cs => 40,
328                   n => 1.3,
329                   Ia => [0,0,0],
330                   Il => [255,255,255],
331                   Is => [255,255,255],
332                  },
333      callsub => sub {
334        my %hsh = @_;
335        for my $cname (qw/Ia Il Is/) {
336          my $old = $hsh{$cname};
337          my $new_color = _color($old)
338            or die $Imager::ERRSTR, "\n";
339          $hsh{$cname} = $new_color;
340        }
341        i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
342                  $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
343                  $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
344                  $hsh{Is});
345      },
346     };
347   $filters{postlevels} =
348     {
349      callseq  => [ qw(image levels) ],
350      defaults => { levels => 10 },
351      callsub  => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
352     };
353   $filters{watermark} =
354     {
355      callseq  => [ qw(image wmark tx ty pixdiff) ],
356      defaults => { pixdiff=>10, tx=>0, ty=>0 },
357      callsub  => 
358      sub { 
359        my %hsh = @_; 
360        i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty}, 
361                    $hsh{pixdiff}); 
362      },
363     };
364   $filters{fountain} =
365     {
366      callseq  => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
367      names    => {
368                   ftype => { linear         => 0,
369                              bilinear       => 1,
370                              radial         => 2,
371                              radial_square  => 3,
372                              revolution     => 4,
373                              conical        => 5 },
374                   repeat => { none      => 0,
375                               sawtooth  => 1,
376                               triangle  => 2,
377                               saw_both  => 3,
378                               tri_both  => 4,
379                             },
380                   super_sample => {
381                                    none    => 0,
382                                    grid    => 1,
383                                    random  => 2,
384                                    circle  => 3,
385                                   },
386                   combine => {
387                               none      => 0,
388                               normal    => 1,
389                               multiply  => 2, mult => 2,
390                               dissolve  => 3,
391                               add       => 4,
392                               subtract  => 5, 'sub' => 5,
393                               diff      => 6,
394                               lighten   => 7,
395                               darken    => 8,
396                               hue       => 9,
397                               sat       => 10,
398                               value     => 11,
399                               color     => 12,
400                              },
401                  },
402      defaults => { ftype => 0, repeat => 0, combine => 0,
403                    super_sample => 0, ssample_param => 4,
404                    segments=>[ 
405                               [ 0, 0.5, 1,
406                                 [0,0,0],
407                                 [255, 255, 255],
408                                 0, 0,
409                               ],
410                              ],
411                  },
412      callsub  => 
413      sub {
414        my %hsh = @_;
415
416        # make sure the segments are specified with colors
417        my @segments;
418        for my $segment (@{$hsh{segments}}) {
419          my @new_segment = @$segment;
420          
421          $_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
422          push @segments, \@new_segment;
423        }
424
425        i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
426                   $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
427                   $hsh{ssample_param}, \@segments)
428          or die Imager->_error_as_msg() . "\n";
429      },
430     };
431   $filters{unsharpmask} =
432     {
433      callseq => [ qw(image stddev scale) ],
434      defaults => { stddev=>2.0, scale=>1.0 },
435      callsub => 
436      sub { 
437        my %hsh = @_;
438        i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
439      },
440     };
441
442   $FORMATGUESS=\&def_guess_type;
443
444   $warn_obsolete = 1;
445 }
446
447 #
448 # Non methods
449 #
450
451 # initialize Imager
452 # NOTE: this might be moved to an import override later on
453
454 sub import {
455   my $i = 1;
456   while ($i < @_) {
457     if ($_[$i] eq '-log-stderr') {
458       init_log(undef, 4);
459       splice(@_, $i, 1);
460     }
461     else {
462       ++$i;
463     }
464   }
465   goto &Exporter::import;
466 }
467
468 sub init_log {
469   Imager->open_log(log => $_[0], level => $_[1]);
470 }
471
472
473 sub init {
474   my %parms=(loglevel=>1,@_);
475
476   if (exists $parms{'warn_obsolete'}) {
477     $warn_obsolete = $parms{'warn_obsolete'};
478   }
479
480   if ($parms{'log'}) {
481     Imager->open_log(log => $parms{log}, level => $parms{loglevel})
482       or return;
483   }
484
485   if (exists $parms{'t1log'}) {
486     if ($formats{t1}) {
487       if (Imager::Font::T1::i_init_t1($parms{'t1log'})) {
488         Imager->_set_error(Imager->_error_as_msg);
489         return;
490       }
491     }
492   }
493
494   return 1;
495 }
496
497 {
498   my $is_logging = 0;
499
500   sub open_log {
501     my $class = shift;
502     my (%opts) = ( loglevel => 1, @_ );
503
504     $is_logging = i_init_log($opts{log}, $opts{loglevel});
505     unless ($is_logging) {
506       Imager->_set_error(Imager->_error_as_msg());
507       return;
508     }
509
510     Imager->log("Imager $VERSION starting\n", 1);
511
512     return $is_logging;
513   }
514
515   sub close_log {
516     i_init_log(undef, -1);
517     $is_logging = 0;
518   }
519
520   sub log {
521     my ($class, $message, $level) = @_;
522
523     defined $level or $level = 1;
524
525     i_log_entry($message, $level);
526   }
527
528   sub is_logging {
529     return $is_logging;
530   }
531 }
532
533 END {
534   if ($DEBUG) {
535     print "shutdown code\n";
536     #   for(keys %instances) { $instances{$_}->DESTROY(); }
537     malloc_state(); # how do decide if this should be used? -- store something from the import
538     print "Imager exiting\n";
539   }
540 }
541
542 # Load a filter plugin
543
544 our %DSOs;
545
546 sub load_plugin {
547   my ($filename)=@_;
548   my $i;
549
550   if ($^O eq 'android') {
551     require File::Spec;
552     $filename = File::Spec->rel2abs($filename);
553   }
554
555   my ($DSO_handle,$str)=DSO_open($filename);
556   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
557   my %funcs=DSO_funclist($DSO_handle);
558   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
559   $i=0;
560   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
561
562   $DSOs{$filename}=[$DSO_handle,\%funcs];
563
564   for(keys %funcs) { 
565     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
566     $DEBUG && print "eval string:\n",$evstr,"\n";
567     eval $evstr;
568     print $@ if $@;
569   }
570   return 1;
571 }
572
573 # Unload a plugin
574
575 sub unload_plugin {
576   my ($filename)=@_;
577
578   if ($^O eq 'android') {
579     require File::Spec;
580     $filename = File::Spec->rel2abs($filename);
581   }
582
583   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
584   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
585   for(keys %{$funcref}) {
586     delete $filters{$_};
587     $DEBUG && print "unloading: $_\n";
588   }
589   my $rc=DSO_close($DSO_handle);
590   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
591   return 1;
592 }
593
594 # take the results of i_error() and make a message out of it
595 sub _error_as_msg {
596   return join(": ", map $_->[0], i_errors());
597 }
598
599 # this function tries to DWIM for color parameters
600 #  color objects are used as is
601 #  simple scalars are simply treated as single parameters to Imager::Color->new
602 #  hashrefs are treated as named argument lists to Imager::Color->new
603 #  arrayrefs are treated as list arguments to Imager::Color->new iff any
604 #    parameter is > 1
605 #  other arrayrefs are treated as list arguments to Imager::Color::Float
606
607 sub _color {
608   my $arg = shift;
609   # perl 5.6.0 seems to do weird things to $arg if we don't make an 
610   # explicitly stringified copy
611   # I vaguely remember a bug on this on p5p, but couldn't find it
612   # through bugs.perl.org (I had trouble getting it to find any bugs)
613   my $copy = $arg . "";
614   my $result;
615
616   if (ref $arg) {
617     if (UNIVERSAL::isa($arg, "Imager::Color")
618         || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
619       $result = $arg;
620     }
621     else {
622       if ($copy =~ /^HASH\(/) {
623         $result = Imager::Color->new(%$arg);
624       }
625       elsif ($copy =~ /^ARRAY\(/) {
626         $result = Imager::Color->new(@$arg);
627       }
628       else {
629         $Imager::ERRSTR = "Not a color";
630       }
631     }
632   }
633   else {
634     # assume Imager::Color::new knows how to handle it
635     $result = Imager::Color->new($arg);
636   }
637
638   return $result;
639 }
640
641 sub _combine {
642   my ($self, $combine, $default) = @_;
643
644   if (!defined $combine && ref $self) {
645     $combine = $self->{combine};
646   }
647   defined $combine or $combine = $defaults{combine};
648   defined $combine or $combine = $default;
649
650   if (exists $combine_types{$combine}) {
651     $combine = $combine_types{$combine};
652   }
653   
654   return $combine;
655 }
656
657 sub _valid_image {
658   my ($self, $method) = @_;
659
660   ref $self
661     or return Imager->_set_error("$method needs an image object");
662
663   $self->{IMG} && Scalar::Util::blessed($self->{IMG}) and return 1;
664
665   my $msg = $self->{IMG} ? "images do not cross threads" : "empty input image";
666   $msg = "$method: $msg" if $method;
667   $self->_set_error($msg);
668
669   return;
670 }
671
672 # returns first defined parameter
673 sub _first {
674   for (@_) {
675     return $_ if defined $_;
676   }
677   return undef;
678 }
679
680 #
681 # Methods to be called on objects.
682 #
683
684 # Create a new Imager object takes very few parameters.
685 # usually you call this method and then call open from
686 # the resulting object
687
688 sub new {
689   my $class = shift;
690   my $self ={};
691   my %hsh=@_;
692   bless $self,$class;
693   $self->{IMG}=undef;    # Just to indicate what exists
694   $self->{ERRSTR}=undef; #
695   $self->{DEBUG}=$DEBUG;
696   $self->{DEBUG} and print "Initialized Imager\n";
697   if (defined $hsh{file} ||
698       defined $hsh{fh} ||
699       defined $hsh{fd} ||
700       defined $hsh{callback} ||
701       defined $hsh{readcb} ||
702       defined $hsh{data} ||
703       defined $hsh{io}) {
704     # allow $img = Imager->new(file => $filename)
705     my %extras;
706     
707     # type is already used as a parameter to new(), rename it for the
708     # call to read()
709     if ($hsh{filetype}) {
710       $extras{type} = $hsh{filetype};
711     }
712     unless ($self->read(%hsh, %extras)) {
713       $Imager::ERRSTR = $self->{ERRSTR};
714       return;
715     }
716   }
717   elsif (defined $hsh{xsize} || defined $hsh{ysize}) {
718     unless ($self->img_set(%hsh)) {
719       $Imager::ERRSTR = $self->{ERRSTR};
720       return;
721     }
722   }
723   elsif (%hsh) {
724     Imager->_set_error("new: supply xsize and ysize or a file access parameter or no parameters");
725     return;
726   }
727
728   return $self;
729 }
730
731 # Copy an entire image with no changes 
732 # - if an image has magic the copy of it will not be magical
733
734 sub copy {
735   my $self = shift;
736
737   $self->_valid_image("copy")
738     or return;
739
740   unless (defined wantarray) {
741     my @caller = caller;
742     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
743     return;
744   }
745
746   my $newcopy=Imager->new();
747   $newcopy->{IMG} = i_copy($self->{IMG});
748   return $newcopy;
749 }
750
751 # Paste a region
752
753 sub paste {
754   my $self = shift;
755
756   $self->_valid_image("paste")
757     or return;
758
759   my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
760   my $src = $input{img} || $input{src};
761   unless($src) {
762     $self->_set_error("no source image");
763     return;
764   }
765   unless ($src->_valid_image("paste")) {
766     $self->{ERRSTR} = $src->{ERRSTR} . " (for src)";
767     return;
768   }
769   $input{left}=0 if $input{left} <= 0;
770   $input{top}=0 if $input{top} <= 0;
771
772   my($r,$b)=i_img_info($src->{IMG});
773   my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
774   my ($src_right, $src_bottom);
775   if ($input{src_coords}) {
776     ($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
777   }
778   else {
779     if (defined $input{src_maxx}) {
780       $src_right = $input{src_maxx};
781     }
782     elsif (defined $input{width}) {
783       if ($input{width} <= 0) {
784         $self->_set_error("paste: width must me positive");
785         return;
786       }
787       $src_right = $src_left + $input{width};
788     }
789     else {
790       $src_right = $r;
791     }
792     if (defined $input{src_maxy}) {
793       $src_bottom = $input{src_maxy};
794     }
795     elsif (defined $input{height}) {
796       if ($input{height} < 0) {
797         $self->_set_error("paste: height must be positive");
798         return;
799       }
800       $src_bottom = $src_top + $input{height};
801     }
802     else {
803       $src_bottom = $b;
804     }
805   }
806
807   $src_right > $r and $src_right = $r;
808   $src_bottom > $b and $src_bottom = $b;
809
810   if ($src_right <= $src_left
811       || $src_bottom < $src_top) {
812     $self->_set_error("nothing to paste");
813     return;
814   }
815
816   i_copyto($self->{IMG}, $src->{IMG}, 
817            $src_left, $src_top, $src_right, $src_bottom, 
818            $input{left}, $input{top});
819
820   return $self;  # What should go here??
821 }
822
823 # Crop an image - i.e. return a new image that is smaller
824
825 sub crop {
826   my $self=shift;
827
828   $self->_valid_image("crop")
829     or return;
830   
831   unless (defined wantarray) {
832     my @caller = caller;
833     warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
834     return;
835   }
836
837   my %hsh=@_;
838
839   my ($w, $h, $l, $r, $b, $t) =
840     @hsh{qw(width height left right bottom top)};
841
842   # work through the various possibilities
843   if (defined $l) {
844     if (defined $w) {
845       $r = $l + $w;
846     }
847     elsif (!defined $r) {
848       $r = $self->getwidth;
849     }
850   }
851   elsif (defined $r) {
852     if (defined $w) {
853       $l = $r - $w;
854     }
855     else {
856       $l = 0;
857     }
858   }
859   elsif (defined $w) {
860     $l = int(0.5+($self->getwidth()-$w)/2);
861     $r = $l + $w;
862   }
863   else {
864     $l = 0;
865     $r = $self->getwidth;
866   }
867   if (defined $t) {
868     if (defined $h) {
869       $b = $t + $h;
870     }
871     elsif (!defined $b) {
872       $b = $self->getheight;
873     }
874   }
875   elsif (defined $b) {
876     if (defined $h) {
877       $t = $b - $h;
878     }
879     else {
880       $t = 0;
881     }
882   }
883   elsif (defined $h) {
884     $t=int(0.5+($self->getheight()-$h)/2);
885     $b=$t+$h;
886   }
887   else {
888     $t = 0;
889     $b = $self->getheight;
890   }
891
892   ($l,$r)=($r,$l) if $l>$r;
893   ($t,$b)=($b,$t) if $t>$b;
894
895   $l < 0 and $l = 0;
896   $r > $self->getwidth and $r = $self->getwidth;
897   $t < 0 and $t = 0;
898   $b > $self->getheight and $b = $self->getheight;
899
900   if ($l == $r || $t == $b) {
901     $self->_set_error("resulting image would have no content");
902     return;
903   }
904   if( $r < $l or $b < $t ) {
905     $self->_set_error("attempting to crop outside of the image");
906     return;
907   }
908   my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
909
910   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
911   return $dst;
912 }
913
914 sub _sametype {
915   my ($self, %opts) = @_;
916
917   $self->_valid_image
918     or return;
919
920   my $x = $opts{xsize} || $self->getwidth;
921   my $y = $opts{ysize} || $self->getheight;
922   my $channels = $opts{channels} || $self->getchannels;
923   
924   my $out = Imager->new;
925   if ($channels == $self->getchannels) {
926     $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
927   }
928   else {
929     $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
930   }
931   unless ($out->{IMG}) {
932     $self->{ERRSTR} = $self->_error_as_msg;
933     return;
934   }
935   
936   return $out;
937 }
938
939 # Sets an image to a certain size and channel number
940 # if there was previously data in the image it is discarded
941
942 my %model_channels =
943   (
944    gray => 1,
945    graya => 2,
946    rgb => 3,
947    rgba => 4,
948   );
949
950 sub img_set {
951   my $self=shift;
952
953   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
954
955   undef($self->{IMG});
956
957   if ($hsh{model}) {
958     if (my $channels = $model_channels{$hsh{model}}) {
959       $hsh{channels} = $channels;
960     }
961     else {
962       $self->_set_error("new: unknown value for model '$hsh{model}'");
963       return;
964     }
965   }
966
967   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
968     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
969                                  $hsh{maxcolors} || 256);
970   }
971   elsif ($hsh{bits} eq 'double') {
972     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
973   }
974   elsif ($hsh{bits} == 16) {
975     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
976   }
977   else {
978     $self->{IMG}= i_img_8_new($hsh{'xsize'}, $hsh{'ysize'},
979                               $hsh{'channels'});
980   }
981
982   unless ($self->{IMG}) {
983     $self->_set_error(Imager->_error_as_msg());
984     return;
985   }
986
987   $self;
988 }
989
990 # created a masked version of the current image
991 sub masked {
992   my $self = shift;
993
994   $self->_valid_image("masked")
995     or return;
996
997   my %opts = (left    => 0, 
998               top     => 0, 
999               right   => $self->getwidth, 
1000               bottom  => $self->getheight,
1001               @_);
1002   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
1003
1004   my $result = Imager->new;
1005   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left}, 
1006                                     $opts{top}, $opts{right} - $opts{left},
1007                                     $opts{bottom} - $opts{top});
1008   unless ($result->{IMG}) {
1009     $self->_set_error(Imager->_error_as_msg);
1010     return;
1011   }
1012
1013   # keep references to the mask and base images so they don't
1014   # disappear on us
1015   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
1016
1017   return $result;
1018 }
1019
1020 # convert an RGB image into a paletted image
1021 sub to_paletted {
1022   my $self = shift;
1023   my $opts;
1024   if (@_ != 1 && !ref $_[0]) {
1025     $opts = { @_ };
1026   }
1027   else {
1028     $opts = shift;
1029   }
1030
1031   unless (defined wantarray) {
1032     my @caller = caller;
1033     warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
1034     return;
1035   }
1036
1037   $self->_valid_image("to_paletted")
1038     or return;
1039
1040   my $result = Imager->new;
1041   unless ($result->{IMG} = i_img_to_pal($self->{IMG}, $opts)) {
1042     $self->_set_error(Imager->_error_as_msg);
1043     return;
1044   }
1045
1046   return $result;
1047 }
1048
1049 sub make_palette {
1050   my ($class, $quant, @images) = @_;
1051
1052   unless (@images) {
1053     Imager->_set_error("make_palette: supply at least one image");
1054     return;
1055   }
1056   my $index = 1;
1057   for my $img (@images) {
1058     unless ($img->{IMG}) {
1059       Imager->_set_error("make_palette: image $index is empty");
1060       return;
1061     }
1062     ++$index;
1063   }
1064
1065   my @cols = i_img_make_palette($quant, map $_->{IMG}, @images);
1066   unless (@cols) {
1067       Imager->_set_error(Imager->_error_as_msg);
1068       return;
1069   }
1070   return @cols;
1071 }
1072
1073 # convert a paletted (or any image) to an 8-bit/channel RGB image
1074 sub to_rgb8 {
1075   my $self = shift;
1076
1077   unless (defined wantarray) {
1078     my @caller = caller;
1079     warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
1080     return;
1081   }
1082
1083   $self->_valid_image("to_rgb8")
1084     or return;
1085
1086   my $result = Imager->new;
1087   unless ($result->{IMG} = i_img_to_rgb($self->{IMG})) {
1088     $self->_set_error(Imager->_error_as_msg());
1089     return;
1090   }
1091
1092   return $result;
1093 }
1094
1095 # convert a paletted (or any image) to a 16-bit/channel RGB image
1096 sub to_rgb16 {
1097   my $self = shift;
1098
1099   unless (defined wantarray) {
1100     my @caller = caller;
1101     warn "to_rgb16() called in void context - to_rgb16() returns the converted image at $caller[1] line $caller[2]\n";
1102     return;
1103   }
1104
1105   $self->_valid_image("to_rgb16")
1106     or return;
1107
1108   my $result = Imager->new;
1109   unless ($result->{IMG} = i_img_to_rgb16($self->{IMG})) {
1110     $self->_set_error(Imager->_error_as_msg());
1111     return;
1112   }
1113
1114   return $result;
1115 }
1116
1117 # convert a paletted (or any image) to an double/channel RGB image
1118 sub to_rgb_double {
1119   my $self = shift;
1120
1121   unless (defined wantarray) {
1122     my @caller = caller;
1123     warn "to_rgb16() called in void context - to_rgb_double() returns the converted image at $caller[1] line $caller[2]\n";
1124     return;
1125   }
1126
1127   $self->_valid_image("to_rgb_double")
1128     or return;
1129
1130   my $result = Imager->new;
1131   unless ($result->{IMG} = i_img_to_drgb($self->{IMG})) {
1132     $self->_set_error(Imager->_error_as_msg());
1133     return;
1134   }
1135
1136   return $result;
1137 }
1138
1139 sub addcolors {
1140   my $self = shift;
1141   my %opts = (colors=>[], @_);
1142
1143   $self->_valid_image("addcolors")
1144     or return -1;
1145
1146   my @colors = @{$opts{colors}}
1147     or return undef;
1148
1149   for my $color (@colors) {
1150     $color = _color($color);
1151     unless ($color) {
1152       $self->_set_error($Imager::ERRSTR);
1153       return;
1154     }  
1155   }
1156
1157   return i_addcolors($self->{IMG}, @colors);
1158 }
1159
1160 sub setcolors {
1161   my $self = shift;
1162   my %opts = (start=>0, colors=>[], @_);
1163
1164   $self->_valid_image("setcolors")
1165     or return;
1166
1167   my @colors = @{$opts{colors}}
1168     or return undef;
1169
1170   for my $color (@colors) {
1171     $color = _color($color);
1172     unless ($color) {
1173       $self->_set_error($Imager::ERRSTR);
1174       return;
1175     }  
1176   }
1177
1178   return i_setcolors($self->{IMG}, $opts{start}, @colors);
1179 }
1180
1181 sub getcolors {
1182   my $self = shift;
1183   my %opts = @_;
1184
1185   $self->_valid_image("getcolors")
1186     or return;
1187
1188   if (!exists $opts{start} && !exists $opts{count}) {
1189     # get them all
1190     $opts{start} = 0;
1191     $opts{count} = $self->colorcount;
1192   }
1193   elsif (!exists $opts{count}) {
1194     $opts{count} = 1;
1195   }
1196   elsif (!exists $opts{start}) {
1197     $opts{start} = 0;
1198   }
1199
1200   return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
1201 }
1202
1203 sub colorcount {
1204   my ($self) = @_;
1205
1206   $self->_valid_image("colorcount")
1207     or return -1;
1208
1209   return i_colorcount($self->{IMG});
1210 }
1211
1212 sub maxcolors {
1213   my $self = shift;
1214
1215   $self->_valid_image("maxcolors")
1216     or return -1;
1217
1218   i_maxcolors($self->{IMG});
1219 }
1220
1221 sub findcolor {
1222   my $self = shift;
1223   my %opts = @_;
1224
1225   $self->_valid_image("findcolor")
1226     or return;
1227
1228   unless ($opts{color}) {
1229     $self->_set_error("findcolor: no color parameter");
1230     return;
1231   }
1232
1233   my $color = _color($opts{color})
1234     or return;
1235
1236   return i_findcolor($self->{IMG}, $color);
1237 }
1238
1239 sub bits {
1240   my $self = shift;
1241
1242   $self->_valid_image("bits")
1243     or return;
1244
1245   my $bits = i_img_bits($self->{IMG});
1246   if ($bits && $bits == length(pack("d", 1)) * 8) {
1247     $bits = 'double';
1248   }
1249   return $bits;
1250 }
1251
1252 sub type {
1253   my $self = shift;
1254
1255   $self->_valid_image("type")
1256     or return;
1257
1258   return i_img_type($self->{IMG}) ? "paletted" : "direct";
1259 }
1260
1261 sub virtual {
1262   my $self = shift;
1263
1264   $self->_valid_image("virtual")
1265     or return;
1266
1267   return i_img_virtual($self->{IMG});
1268 }
1269
1270 sub is_bilevel {
1271   my ($self) = @_;
1272
1273   $self->_valid_image("is_bilevel")
1274     or return;
1275
1276   return i_img_is_monochrome($self->{IMG});
1277 }
1278
1279 sub tags {
1280   my ($self, %opts) = @_;
1281
1282   $self->_valid_image("tags")
1283     or return;
1284
1285   if (defined $opts{name}) {
1286     my @result;
1287     my $start = 0;
1288     my $found;
1289     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1290       push @result, (i_tags_get($self->{IMG}, $found))[1];
1291       $start = $found+1;
1292     }
1293     return wantarray ? @result : $result[0];
1294   }
1295   elsif (defined $opts{code}) {
1296     my @result;
1297     my $start = 0;
1298     my $found;
1299     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1300       push @result, (i_tags_get($self->{IMG}, $found))[1];
1301       $start = $found+1;
1302     }
1303     return @result;
1304   }
1305   else {
1306     if (wantarray) {
1307       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1308     }
1309     else {
1310       return i_tags_count($self->{IMG});
1311     }
1312   }
1313 }
1314
1315 sub addtag {
1316   my $self = shift;
1317   my %opts = @_;
1318
1319   $self->_valid_image("addtag")
1320     or return;
1321
1322   if ($opts{name}) {
1323     if (defined $opts{value}) {
1324       if ($opts{value} =~ /^\d+$/) {
1325         # add as a number
1326         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1327       }
1328       else {
1329         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1330       }
1331     }
1332     elsif (defined $opts{data}) {
1333       # force addition as a string
1334       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1335     }
1336     else {
1337       $self->{ERRSTR} = "No value supplied";
1338       return undef;
1339     }
1340   }
1341   elsif ($opts{code}) {
1342     if (defined $opts{value}) {
1343       if ($opts{value} =~ /^\d+$/) {
1344         # add as a number
1345         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1346       }
1347       else {
1348         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1349       }
1350     }
1351     elsif (defined $opts{data}) {
1352       # force addition as a string
1353       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1354     }
1355     else {
1356       $self->{ERRSTR} = "No value supplied";
1357       return undef;
1358     }
1359   }
1360   else {
1361     return undef;
1362   }
1363 }
1364
1365 sub deltag {
1366   my $self = shift;
1367   my %opts = @_;
1368
1369   $self->_valid_image("deltag")
1370     or return 0;
1371
1372   if (defined $opts{'index'}) {
1373     return i_tags_delete($self->{IMG}, $opts{'index'});
1374   }
1375   elsif (defined $opts{name}) {
1376     return i_tags_delbyname($self->{IMG}, $opts{name});
1377   }
1378   elsif (defined $opts{code}) {
1379     return i_tags_delbycode($self->{IMG}, $opts{code});
1380   }
1381   else {
1382     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1383     return 0;
1384   }
1385 }
1386
1387 sub settag {
1388   my ($self, %opts) = @_;
1389
1390   $self->_valid_image("settag")
1391     or return;
1392
1393   if ($opts{name}) {
1394     $self->deltag(name=>$opts{name});
1395     return $self->addtag(name=>$opts{name}, value=>$opts{value});
1396   }
1397   elsif (defined $opts{code}) {
1398     $self->deltag(code=>$opts{code});
1399     return $self->addtag(code=>$opts{code}, value=>$opts{value});
1400   }
1401   else {
1402     return undef;
1403   }
1404 }
1405
1406
1407 sub _get_reader_io {
1408   my ($self, $input) = @_;
1409
1410   if ($input->{io}) {
1411     return $input->{io}, undef;
1412   }
1413   elsif ($input->{fd}) {
1414     return io_new_fd($input->{fd});
1415   }
1416   elsif ($input->{fh}) {
1417     unless (Scalar::Util::openhandle($input->{fh})) {
1418       $self->_set_error("Handle in fh option not opened");
1419       return;
1420     }
1421     return Imager::IO->new_fh($input->{fh});
1422   }
1423   elsif ($input->{file}) {
1424     my $file = IO::File->new($input->{file}, "r");
1425     unless ($file) {
1426       $self->_set_error("Could not open $input->{file}: $!");
1427       return;
1428     }
1429     binmode $file;
1430     return (io_new_fd(fileno($file)), $file);
1431   }
1432   elsif ($input->{data}) {
1433     return io_new_buffer($input->{data});
1434   }
1435   elsif ($input->{callback} || $input->{readcb}) {
1436     if (!$input->{seekcb}) {
1437       $self->_set_error("Need a seekcb parameter");
1438     }
1439     if ($input->{maxbuffer}) {
1440       return io_new_cb($input->{writecb},
1441                        $input->{callback} || $input->{readcb},
1442                        $input->{seekcb}, $input->{closecb},
1443                        $input->{maxbuffer});
1444     }
1445     else {
1446       return io_new_cb($input->{writecb},
1447                        $input->{callback} || $input->{readcb},
1448                        $input->{seekcb}, $input->{closecb});
1449     }
1450   }
1451   else {
1452     $self->_set_error("file/fd/fh/data/callback parameter missing");
1453     return;
1454   }
1455 }
1456
1457 sub _get_writer_io {
1458   my ($self, $input) = @_;
1459
1460   my $buffered = exists $input->{buffered} ? $input->{buffered} : 1;
1461
1462   my $io;
1463   my @extras;
1464   if ($input->{io}) {
1465     $io = $input->{io};
1466   }
1467   elsif ($input->{fd}) {
1468     $io = io_new_fd($input->{fd});
1469   }
1470   elsif ($input->{fh}) {
1471     unless (Scalar::Util::openhandle($input->{fh})) {
1472       $self->_set_error("Handle in fh option not opened");
1473       return;
1474     }
1475     $io = Imager::IO->new_fh($input->{fh});
1476   }
1477   elsif ($input->{file}) {
1478     my $fh = new IO::File($input->{file},"w+");
1479     unless ($fh) { 
1480       $self->_set_error("Could not open file $input->{file}: $!");
1481       return;
1482     }
1483     binmode($fh) or die;
1484     $io = io_new_fd(fileno($fh));
1485     push @extras, $fh;
1486   }
1487   elsif ($input->{data}) {
1488     $io = io_new_bufchain();
1489   }
1490   elsif ($input->{callback} || $input->{writecb}) {
1491     if ($input->{maxbuffer} && $input->{maxbuffer} == 1) {
1492       $buffered = 0;
1493     }
1494     $io = io_new_cb($input->{callback} || $input->{writecb},
1495                     $input->{readcb},
1496                     $input->{seekcb}, $input->{closecb});
1497   }
1498   else {
1499     $self->_set_error("file/fd/fh/data/callback parameter missing");
1500     return;
1501   }
1502
1503   unless ($buffered) {
1504     $io->set_buffered(0);
1505   }
1506
1507   return ($io, @extras);
1508 }
1509
1510 sub _test_format {
1511   my ($io) = @_;
1512
1513   return i_test_format_probe($io, -1);
1514 }
1515
1516 sub add_file_magic {
1517   my ($class, %opts) = @_;
1518
1519   my $name = delete $opts{name};
1520   my $bits = delete $opts{bits};
1521   my $mask = delete $opts{mask};
1522
1523   unless (i_add_file_magic($name, $bits, $mask)) {
1524     Imager->_set_error(Imager->_error_as_msg);
1525     return;
1526   }
1527
1528   1;
1529 }
1530
1531 # Read an image from file
1532
1533 sub read {
1534   my $self = shift;
1535   my %input=@_;
1536
1537   if (defined($self->{IMG})) {
1538     # let IIM_DESTROY do the destruction, since the image may be
1539     # referenced from elsewhere
1540     #i_img_destroy($self->{IMG});
1541     undef($self->{IMG});
1542   }
1543
1544   my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1545
1546   my $type = $input{'type'};
1547   unless ($type) {
1548     $type = _test_format($IO);
1549   }
1550
1551   if ($input{file} && !$type) {
1552     # guess the type 
1553     $type = $FORMATGUESS->($input{file});
1554   }
1555
1556   unless ($type) {
1557     my $msg = "type parameter missing and it couldn't be determined from the file contents";
1558     $input{file} and $msg .= " or file name";
1559     $self->_set_error($msg);
1560     return undef;
1561   }
1562
1563   _reader_autoload($type);
1564
1565   if ($readers{$type} && $readers{$type}{single}) {
1566     return $readers{$type}{single}->($self, $IO, %input);
1567   }
1568
1569   unless ($formats_low{$type}) {
1570     my $read_types = join ', ', sort Imager->read_types();
1571     $self->_set_error("format '$type' not supported - formats $read_types available for reading - $reader_load_errors{$type}");
1572     return;
1573   }
1574
1575   my $allow_incomplete = $input{allow_incomplete};
1576   defined $allow_incomplete or $allow_incomplete = 0;
1577
1578   if ( $type eq 'pnm' ) {
1579     $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
1580     if ( !defined($self->{IMG}) ) {
1581       $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); 
1582       return undef;
1583     }
1584     $self->{DEBUG} && print "loading a pnm file\n";
1585     return $self;
1586   }
1587
1588   if ( $type eq 'bmp' ) {
1589     $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
1590     if ( !defined($self->{IMG}) ) {
1591       $self->{ERRSTR}=$self->_error_as_msg();
1592       return undef;
1593     }
1594     $self->{DEBUG} && print "loading a bmp file\n";
1595   }
1596
1597   if ( $type eq 'tga' ) {
1598     $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1599     if ( !defined($self->{IMG}) ) {
1600       $self->{ERRSTR}=$self->_error_as_msg();
1601       return undef;
1602     }
1603     $self->{DEBUG} && print "loading a tga file\n";
1604   }
1605
1606   if ( $type eq 'raw' ) {
1607     unless ( $input{xsize} && $input{ysize} ) {
1608       $self->_set_error('missing xsize or ysize parameter for raw');
1609       return undef;
1610     }
1611
1612     my $interleave = _first($input{raw_interleave}, $input{interleave});
1613     unless (defined $interleave) {
1614       my @caller = caller;
1615       warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
1616       $interleave = 1;
1617     }
1618     my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
1619     my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
1620
1621     $self->{IMG} = i_readraw_wiol( $IO,
1622                                    $input{xsize},
1623                                    $input{ysize},
1624                                    $data_ch,
1625                                    $store_ch,
1626                                    $interleave);
1627     if ( !defined($self->{IMG}) ) {
1628       $self->{ERRSTR}=$self->_error_as_msg();
1629       return undef;
1630     }
1631     $self->{DEBUG} && print "loading a raw file\n";
1632   }
1633
1634   return $self;
1635 }
1636
1637 sub register_reader {
1638   my ($class, %opts) = @_;
1639
1640   defined $opts{type}
1641     or die "register_reader called with no type parameter\n";
1642
1643   my $type = $opts{type};
1644
1645   defined $opts{single} || defined $opts{multiple}
1646     or die "register_reader called with no single or multiple parameter\n";
1647
1648   $readers{$type} = {  };
1649   if ($opts{single}) {
1650     $readers{$type}{single} = $opts{single};
1651   }
1652   if ($opts{multiple}) {
1653     $readers{$type}{multiple} = $opts{multiple};
1654   }
1655
1656   return 1;
1657 }
1658
1659 sub register_writer {
1660   my ($class, %opts) = @_;
1661
1662   defined $opts{type}
1663     or die "register_writer called with no type parameter\n";
1664
1665   my $type = $opts{type};
1666
1667   defined $opts{single} || defined $opts{multiple}
1668     or die "register_writer called with no single or multiple parameter\n";
1669
1670   $writers{$type} = {  };
1671   if ($opts{single}) {
1672     $writers{$type}{single} = $opts{single};
1673   }
1674   if ($opts{multiple}) {
1675     $writers{$type}{multiple} = $opts{multiple};
1676   }
1677
1678   return 1;
1679 }
1680
1681 sub read_types {
1682   my %types =
1683     (
1684      map { $_ => 1 }
1685      keys %readers,
1686      grep($file_formats{$_}, keys %formats),
1687      qw(ico sgi), # formats not handled directly, but supplied with Imager
1688     );
1689
1690   return keys %types;
1691 }
1692
1693 sub write_types {
1694   my %types =
1695     (
1696      map { $_ => 1 }
1697      keys %writers,
1698      grep($file_formats{$_}, keys %formats),
1699      qw(ico sgi), # formats not handled directly, but supplied with Imager
1700     );
1701
1702   return keys %types;
1703 }
1704
1705 sub _load_file {
1706   my ($file, $error) = @_;
1707
1708   if ($attempted_to_load{$file}) {
1709     if ($file_load_errors{$file}) {
1710       $$error = $file_load_errors{$file};
1711       return 0;
1712     }
1713     else {
1714       return 1;
1715     }
1716   }
1717   else {
1718     local $SIG{__DIE__};
1719     my $loaded = eval {
1720       local @INC = @INC;
1721       pop @INC if $INC[-1] eq '.';
1722       ++$attempted_to_load{$file};
1723       require $file;
1724       return 1;
1725     };
1726     if ($loaded) {
1727       return 1;
1728     }
1729     else {
1730       my $work = $@ || "Unknown error";
1731       chomp $work;
1732       $work =~ s/\n?Compilation failed in require at .*Imager\.pm line .*\z//m;
1733       $work =~ s/\n/\\n/g;
1734       $work =~ s/\s*\.?\z/ loading $file/;
1735       $file_load_errors{$file} = $work;
1736       $$error = $work;
1737       return 0;
1738     }
1739   }
1740 }
1741
1742 # probes for an Imager::File::whatever module
1743 sub _reader_autoload {
1744   my $type = shift;
1745
1746   return if $formats_low{$type} || $readers{$type};
1747
1748   return unless $type =~ /^\w+$/;
1749
1750   my $file = "Imager/File/\U$type\E.pm";
1751
1752   my $error;
1753   my $loaded = _load_file($file, \$error);
1754   if (!$loaded && $error =~ /^Can't locate /) {
1755     my $filer = "Imager/File/\U$type\EReader.pm";
1756     $loaded = _load_file($filer, \$error);
1757     if ($error =~ /^Can't locate /) {
1758       $error = "Can't locate $file or $filer";
1759     }
1760   }
1761   unless ($loaded) {
1762     $reader_load_errors{$type} = $error;
1763   }
1764 }
1765
1766 # probes for an Imager::File::whatever module
1767 sub _writer_autoload {
1768   my $type = shift;
1769
1770   return if $formats_low{$type} || $writers{$type};
1771
1772   return unless $type =~ /^\w+$/;
1773
1774   my $file = "Imager/File/\U$type\E.pm";
1775
1776   my $error;
1777   my $loaded = _load_file($file, \$error);
1778   if (!$loaded && $error =~ /^Can't locate /) {
1779     my $filew = "Imager/File/\U$type\EWriter.pm";
1780     $loaded = _load_file($filew, \$error);
1781     if ($error =~ /^Can't locate /) {
1782       $error = "Can't locate $file or $filew";
1783     }
1784   }
1785   unless ($loaded) {
1786     $writer_load_errors{$type} = $error;
1787   }
1788 }
1789
1790 sub _fix_gif_positions {
1791   my ($opts, $opt, $msg, @imgs) = @_;
1792
1793   my $positions = $opts->{'gif_positions'};
1794   my $index = 0;
1795   for my $pos (@$positions) {
1796     my ($x, $y) = @$pos;
1797     my $img = $imgs[$index++];
1798     $img->settag(name=>'gif_left', value=>$x);
1799     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1800   }
1801   $$msg .= "replaced with the gif_left and gif_top tags";
1802 }
1803
1804 my %obsolete_opts =
1805   (
1806    gif_each_palette=>'gif_local_map',
1807    interlace       => 'gif_interlace',
1808    gif_delays => 'gif_delay',
1809    gif_positions => \&_fix_gif_positions,
1810    gif_loop_count => 'gif_loop',
1811   );
1812
1813 # options that should be converted to colors
1814 my %color_opts = map { $_ => 1 } qw/i_background/;
1815
1816 sub _set_opts {
1817   my ($self, $opts, $prefix, @imgs) = @_;
1818
1819   for my $opt (keys %$opts) {
1820     my $tagname = $opt;
1821     if ($obsolete_opts{$opt}) {
1822       my $new = $obsolete_opts{$opt};
1823       my $msg = "Obsolete option $opt ";
1824       if (ref $new) {
1825         $new->($opts, $opt, \$msg, @imgs);
1826       }
1827       else {
1828         $msg .= "replaced with the $new tag ";
1829         $tagname = $new;
1830       }
1831       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1832       warn $msg if $warn_obsolete && $^W;
1833     }
1834     next unless $tagname =~ /^\Q$prefix/;
1835     my $value = $opts->{$opt};
1836     if ($color_opts{$opt}) {
1837       $value = _color($value);
1838       unless ($value) {
1839         $self->_set_error($Imager::ERRSTR);
1840         return;
1841       }
1842     }
1843     if (ref $value) {
1844       if (UNIVERSAL::isa($value, "Imager::Color")) {
1845         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1846         for my $img (@imgs) {
1847           $img->settag(name=>$tagname, value=>$tag);
1848         }
1849       }
1850       elsif (ref($value) eq 'ARRAY') {
1851         for my $i (0..$#$value) {
1852           my $val = $value->[$i];
1853           if (ref $val) {
1854             if (UNIVERSAL::isa($val, "Imager::Color")) {
1855               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1856               $i < @imgs and
1857                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1858             }
1859             else {
1860               $self->_set_error("Unknown reference type " . ref($value) . 
1861                                 " supplied in array for $opt");
1862               return;
1863             }
1864           }
1865           else {
1866             $i < @imgs
1867               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1868           }
1869         }
1870       }
1871       else {
1872         $self->_set_error("Unknown reference type " . ref($value) . 
1873                           " supplied for $opt");
1874         return;
1875       }
1876     }
1877     else {
1878       # set it as a tag for every image
1879       for my $img (@imgs) {
1880         $img->settag(name=>$tagname, value=>$value);
1881       }
1882     }
1883   }
1884
1885   return 1;
1886 }
1887
1888 # Write an image to file
1889 sub write {
1890   my $self = shift;
1891   my %input=(jpegquality=>75,
1892              gifquant=>'mc',
1893              lmdither=>6.0,
1894              lmfixed=>[],
1895              idstring=>"",
1896              compress=>1,
1897              wierdpack=>0,
1898              fax_fine=>1, @_);
1899   my $rc;
1900
1901   $self->_valid_image("write")
1902     or return;
1903
1904   $self->_set_opts(\%input, "i_", $self)
1905     or return undef;
1906
1907   my $type = $input{'type'};
1908   if (!$type and $input{file}) { 
1909     $type = $FORMATGUESS->($input{file});
1910   }
1911   unless ($type) { 
1912     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1913     return undef;
1914   }
1915
1916   _writer_autoload($type);
1917
1918   my ($IO, $fh);
1919   if ($writers{$type} && $writers{$type}{single}) {
1920     ($IO, $fh) = $self->_get_writer_io(\%input)
1921       or return undef;
1922
1923     $writers{$type}{single}->($self, $IO, %input, type => $type)
1924       or return undef;
1925   }
1926   else {
1927     if (!$formats_low{$type}) { 
1928       my $write_types = join ', ', sort Imager->write_types();
1929       $self->_set_error("format '$type' not supported - formats $write_types available for writing - $writer_load_errors{$type}");
1930       return undef;
1931     }
1932     
1933     ($IO, $fh) = $self->_get_writer_io(\%input, $type)
1934       or return undef;
1935   
1936     if ( $type eq 'pnm' ) {
1937       $self->_set_opts(\%input, "pnm_", $self)
1938         or return undef;
1939       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1940         $self->{ERRSTR} = $self->_error_as_msg();
1941         return undef;
1942       }
1943       $self->{DEBUG} && print "writing a pnm file\n";
1944     }
1945     elsif ( $type eq 'raw' ) {
1946       $self->_set_opts(\%input, "raw_", $self)
1947         or return undef;
1948       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1949         $self->{ERRSTR} = $self->_error_as_msg();
1950         return undef;
1951       }
1952       $self->{DEBUG} && print "writing a raw file\n";
1953     }
1954     elsif ( $type eq 'bmp' ) {
1955       $self->_set_opts(\%input, "bmp_", $self)
1956         or return undef;
1957       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1958         $self->{ERRSTR} = $self->_error_as_msg;
1959         return undef;
1960       }
1961       $self->{DEBUG} && print "writing a bmp file\n";
1962     }
1963     elsif ( $type eq 'tga' ) {
1964       $self->_set_opts(\%input, "tga_", $self)
1965         or return undef;
1966       
1967       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1968         $self->{ERRSTR}=$self->_error_as_msg();
1969         return undef;
1970       }
1971       $self->{DEBUG} && print "writing a tga file\n";
1972     }
1973   }
1974
1975   if (exists $input{'data'}) {
1976     my $data = io_slurp($IO);
1977     if (!$data) {
1978       $self->{ERRSTR}='Could not slurp from buffer';
1979       return undef;
1980     }
1981     ${$input{data}} = $data;
1982   }
1983   return $self;
1984 }
1985
1986 sub write_multi {
1987   my ($class, $opts, @images) = @_;
1988
1989   my $type = $opts->{type};
1990
1991   if (!$type && $opts->{'file'}) {
1992     $type = $FORMATGUESS->($opts->{'file'});
1993   }
1994   unless ($type) {
1995     $class->_set_error('type parameter missing and not possible to guess from extension');
1996     return;
1997   }
1998   # translate to ImgRaw
1999   my $index = 1;
2000   for my $img (@images) {
2001     unless (ref $img && Scalar::Util::blessed($img) && $img->isa("Imager")) {
2002       $class->_set_error("write_multi: image $index is not an Imager image object");
2003       return;
2004     }
2005     unless ($img->_valid_image("write_multi")) {
2006       $class->_set_error($img->errstr . " (image $index)");
2007       return;
2008     }
2009     ++$index;
2010   }
2011   $class->_set_opts($opts, "i_", @images)
2012     or return;
2013   my @work = map $_->{IMG}, @images;
2014
2015   _writer_autoload($type);
2016
2017   my ($IO, $file);
2018   if ($writers{$type} && $writers{$type}{multiple}) {
2019     ($IO, $file) = $class->_get_writer_io($opts, $type)
2020       or return undef;
2021
2022     $writers{$type}{multiple}->($class, $IO, $opts, @images)
2023       or return undef;
2024   }
2025   else {
2026     if (!$formats{$type}) { 
2027       my $write_types = join ', ', sort Imager->write_types();
2028       $class->_set_error("format '$type' not supported - formats $write_types available for writing");
2029       return undef;
2030     }
2031     
2032     ($IO, $file) = $class->_get_writer_io($opts, $type)
2033       or return undef;
2034     
2035     if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
2036     }
2037     else {
2038       if (@images == 1) {
2039         unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
2040           return 1;
2041         }
2042       }
2043       else {
2044         $ERRSTR = "Sorry, write_multi doesn't support $type yet";
2045         return 0;
2046       }
2047     }
2048   }
2049
2050   if (exists $opts->{'data'}) {
2051     my $data = io_slurp($IO);
2052     if (!$data) {
2053       Imager->_set_error('Could not slurp from buffer');
2054       return undef;
2055     }
2056     ${$opts->{data}} = $data;
2057   }
2058   return 1;
2059 }
2060
2061 # read multiple images from a file
2062 sub read_multi {
2063   my ($class, %opts) = @_;
2064
2065   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
2066     or return;
2067
2068   my $type = $opts{'type'};
2069   unless ($type) {
2070     $type = _test_format($IO);
2071   }
2072
2073   if ($opts{file} && !$type) {
2074     # guess the type 
2075     $type = $FORMATGUESS->($opts{file});
2076   }
2077
2078   unless ($type) {
2079     my $msg = "type parameter missing and it couldn't be determined from the file contents";
2080     $opts{file} and $msg .= " or file name";
2081     Imager->_set_error($msg);
2082     return;
2083   }
2084
2085   _reader_autoload($type);
2086
2087   if ($readers{$type} && $readers{$type}{multiple}) {
2088     return $readers{$type}{multiple}->($IO, %opts);
2089   }
2090
2091   unless ($formats{$type}) {
2092     my $read_types = join ', ', sort Imager->read_types();
2093     Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
2094     return;
2095   }
2096
2097   my @imgs;
2098   if ($type eq 'pnm') {
2099     @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
2100   }
2101   else {
2102     my $img = Imager->new;
2103     if ($img->read(%opts, io => $IO, type => $type)) {
2104       return ( $img );
2105     }
2106     Imager->_set_error($img->errstr);
2107     return;
2108   }
2109
2110   if (!@imgs) {
2111     $ERRSTR = _error_as_msg();
2112   return;
2113   }
2114   return map { 
2115         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager' 
2116       } @imgs;
2117 }
2118
2119 # Destroy an Imager object
2120
2121 sub DESTROY {
2122   my $self=shift;
2123   #    delete $instances{$self};
2124   if (defined($self->{IMG})) {
2125     # the following is now handled by the XS DESTROY method for
2126     # Imager::ImgRaw object
2127     # Re-enabling this will break virtual images
2128     # tested for in t/t020masked.t
2129     # i_img_destroy($self->{IMG});
2130     undef($self->{IMG});
2131   } else {
2132 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
2133   }
2134 }
2135
2136 # Perform an inplace filter of an image
2137 # that is the image will be overwritten with the data
2138
2139 sub filter {
2140   my $self=shift;
2141   my %input=@_;
2142   my %hsh;
2143
2144   $self->_valid_image("filter")
2145     or return;
2146
2147   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
2148
2149   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
2150     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2151   }
2152
2153   if ($filters{$input{'type'}}{names}) {
2154     my $names = $filters{$input{'type'}}{names};
2155     for my $name (keys %$names) {
2156       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2157         $input{$name} = $names->{$name}{$input{$name}};
2158       }
2159     }
2160   }
2161   if (defined($filters{$input{'type'}}{defaults})) {
2162     %hsh=( image => $self->{IMG},
2163            imager => $self,
2164            %{$filters{$input{'type'}}{defaults}},
2165            %input );
2166   } else {
2167     %hsh=( image => $self->{IMG},
2168            imager => $self,
2169            %input );
2170   }
2171
2172   my @cs=@{$filters{$input{'type'}}{callseq}};
2173
2174   for(@cs) {
2175     if (!defined($hsh{$_})) {
2176       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
2177     }
2178   }
2179
2180   eval {
2181     local $SIG{__DIE__}; # we don't want this processed by confess, etc
2182     &{$filters{$input{'type'}}{callsub}}(%hsh);
2183   };
2184   if ($@) {
2185     chomp($self->{ERRSTR} = $@);
2186     return;
2187   }
2188
2189   my @b=keys %hsh;
2190
2191   $self->{DEBUG} && print "callseq is: @cs\n";
2192   $self->{DEBUG} && print "matching callseq is: @b\n";
2193
2194   return $self;
2195 }
2196
2197 sub register_filter {
2198   my $class = shift;
2199   my %hsh = ( defaults => {}, @_ );
2200
2201   defined $hsh{type}
2202     or die "register_filter() with no type\n";
2203   defined $hsh{callsub}
2204     or die "register_filter() with no callsub\n";
2205   defined $hsh{callseq}
2206     or die "register_filter() with no callseq\n";
2207
2208   exists $filters{$hsh{type}}
2209     and return;
2210
2211   $filters{$hsh{type}} = \%hsh;
2212
2213   return 1;
2214 }
2215
2216 sub scale_calculate {
2217   my $self = shift;
2218
2219   my %opts = ('type'=>'max', @_);
2220
2221   # none of these should be references
2222   for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2223     if (defined $opts{$name} && ref $opts{$name}) {
2224       $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2225       return;
2226     }
2227   }
2228
2229   my ($x_scale, $y_scale);
2230   my $width = $opts{width};
2231   my $height = $opts{height};
2232   if (ref $self) {
2233     defined $width or $width = $self->getwidth;
2234     defined $height or $height = $self->getheight;
2235   }
2236   else {
2237     unless (defined $width && defined $height) {
2238       $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2239       return;
2240     }
2241   }
2242
2243   if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2244     $x_scale = $opts{'xscalefactor'};
2245     $y_scale = $opts{'yscalefactor'};
2246   }
2247   elsif ($opts{'xscalefactor'}) {
2248     $x_scale = $opts{'xscalefactor'};
2249     $y_scale = $opts{'scalefactor'} || $x_scale;
2250   }
2251   elsif ($opts{'yscalefactor'}) {
2252     $y_scale = $opts{'yscalefactor'};
2253     $x_scale = $opts{'scalefactor'} || $y_scale;
2254   }
2255   else {
2256     $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2257   }
2258
2259   # work out the scaling
2260   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
2261     my ($xpix, $ypix)=( $opts{xpixels} / $width , 
2262                         $opts{ypixels} / $height );
2263     if ($opts{'type'} eq 'min') { 
2264       $x_scale = $y_scale = _min($xpix,$ypix); 
2265     }
2266     elsif ($opts{'type'} eq 'max') {
2267       $x_scale = $y_scale = _max($xpix,$ypix);
2268     }
2269     elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2270       $x_scale = $xpix;
2271       $y_scale = $ypix;
2272     }
2273     else {
2274       $self->_set_error('invalid value for type parameter');
2275       return;
2276     }
2277   } elsif ($opts{xpixels}) { 
2278     $x_scale = $y_scale = $opts{xpixels} / $width;
2279   }
2280   elsif ($opts{ypixels}) { 
2281     $x_scale = $y_scale = $opts{ypixels}/$height;
2282   }
2283   elsif ($opts{constrain} && ref $opts{constrain}
2284          && $opts{constrain}->can('constrain')) {
2285     # we've been passed an Image::Math::Constrain object or something
2286     # that looks like one
2287     my $scalefactor;
2288     (undef, undef, $scalefactor)
2289       = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2290     unless ($scalefactor) {
2291       $self->_set_error('constrain method failed on constrain parameter');
2292       return;
2293     }
2294     $x_scale = $y_scale = $scalefactor;
2295   }
2296
2297   my $new_width = int($x_scale * $width + 0.5);
2298   $new_width > 0 or $new_width = 1;
2299   my $new_height = int($y_scale * $height + 0.5);
2300   $new_height > 0 or $new_height = 1;
2301
2302   return ($x_scale, $y_scale, $new_width, $new_height);
2303   
2304 }
2305
2306 # Scale an image to requested size and return the scaled version
2307
2308 sub scale {
2309   my $self=shift;
2310   my %opts = (qtype=>'normal' ,@_);
2311   my $img = Imager->new();
2312   my $tmp = Imager->new();
2313
2314   unless (defined wantarray) {
2315     my @caller = caller;
2316     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2317     return;
2318   }
2319
2320   $self->_valid_image("scale")
2321     or return;
2322
2323   my ($x_scale, $y_scale, $new_width, $new_height) = 
2324     $self->scale_calculate(%opts)
2325       or return;
2326
2327   if ($opts{qtype} eq 'normal') {
2328     $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2329     if ( !defined($tmp->{IMG}) ) { 
2330       $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
2331       return undef;
2332     }
2333     $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2334     if ( !defined($img->{IMG}) ) { 
2335       $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg; 
2336       return undef;
2337     }
2338
2339     return $img;
2340   }
2341   elsif ($opts{'qtype'} eq 'preview') {
2342     $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale); 
2343     if ( !defined($img->{IMG}) ) { 
2344       $self->{ERRSTR}='unable to scale image'; 
2345       return undef;
2346     }
2347     return $img;
2348   }
2349   elsif ($opts{'qtype'} eq 'mixing') {
2350     $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2351     unless ($img->{IMG}) {
2352       $self->_set_error(Imager->_error_as_msg);
2353       return;
2354     }
2355     return $img;
2356   }
2357   else {
2358     $self->_set_error('invalid value for qtype parameter');
2359     return undef;
2360   }
2361 }
2362
2363 # Scales only along the X axis
2364
2365 sub scaleX {
2366   my $self = shift;
2367   my %opts = ( scalefactor=>0.5, @_ );
2368
2369   unless (defined wantarray) {
2370     my @caller = caller;
2371     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2372     return;
2373   }
2374
2375   $self->_valid_image("scaleX")
2376     or return;
2377
2378   my $img = Imager->new();
2379
2380   my $scalefactor = $opts{scalefactor};
2381
2382   if ($opts{pixels}) { 
2383     $scalefactor = $opts{pixels} / $self->getwidth();
2384   }
2385
2386   unless ($self->{IMG}) { 
2387     $self->{ERRSTR}='empty input image'; 
2388     return undef;
2389   }
2390
2391   $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2392
2393   if ( !defined($img->{IMG}) ) { 
2394     $self->{ERRSTR} = 'unable to scale image'; 
2395     return undef;
2396   }
2397
2398   return $img;
2399 }
2400
2401 # Scales only along the Y axis
2402
2403 sub scaleY {
2404   my $self = shift;
2405   my %opts = ( scalefactor => 0.5, @_ );
2406
2407   unless (defined wantarray) {
2408     my @caller = caller;
2409     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2410     return;
2411   }
2412
2413   $self->_valid_image("scaleY")
2414     or return;
2415
2416   my $img = Imager->new();
2417
2418   my $scalefactor = $opts{scalefactor};
2419
2420   if ($opts{pixels}) { 
2421     $scalefactor = $opts{pixels} / $self->getheight();
2422   }
2423
2424   unless ($self->{IMG}) { 
2425     $self->{ERRSTR} = 'empty input image'; 
2426     return undef;
2427   }
2428   $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2429
2430   if ( !defined($img->{IMG}) ) {
2431     $self->{ERRSTR} = 'unable to scale image';
2432     return undef;
2433   }
2434
2435   return $img;
2436 }
2437
2438 # Transform returns a spatial transformation of the input image
2439 # this moves pixels to a new location in the returned image.
2440 # NOTE - should make a utility function to check transforms for
2441 # stack overruns
2442
2443 our $I2P;
2444
2445 sub transform {
2446   my $self=shift;
2447   my %opts=@_;
2448   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2449
2450 #  print Dumper(\%opts);
2451 #  xopcopdes
2452
2453   $self->_valid_image("transform")
2454     or return;
2455
2456   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2457     if (!$I2P) {
2458       {
2459         local @INC = @INC;
2460         pop @INC if $INC[-1] eq '.';
2461         eval ("use Affix::Infix2Postfix;");
2462       }
2463
2464       if ( $@ ) {
2465         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.'; 
2466         return undef;
2467       }
2468       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2469                                              {op=>'-',trans=>'Sub'},
2470                                              {op=>'*',trans=>'Mult'},
2471                                              {op=>'/',trans=>'Div'},
2472                                              {op=>'-','type'=>'unary',trans=>'u-'},
2473                                              {op=>'**'},
2474                                              {op=>'func','type'=>'unary'}],
2475                                      'grouping'=>[qw( \( \) )],
2476                                      'func'=>[qw( sin cos )],
2477                                      'vars'=>[qw( x y )]
2478                                     );
2479     }
2480
2481     @xt=$I2P->translate($opts{'xexpr'});
2482     @yt=$I2P->translate($opts{'yexpr'});
2483
2484     $numre=$I2P->{'numre'};
2485     @pt=(0,0);
2486
2487     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2488     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2489     @{$opts{'parm'}}=@pt;
2490   }
2491
2492 #  print Dumper(\%opts);
2493
2494   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2495     $self->{ERRSTR}='transform: no xopcodes given.';
2496     return undef;
2497   }
2498
2499   @op=@{$opts{'xopcodes'}};
2500   for $iop (@op) { 
2501     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2502       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2503       return undef;
2504     }
2505     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2506   }
2507
2508
2509 # yopcopdes
2510
2511   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2512     $self->{ERRSTR}='transform: no yopcodes given.';
2513     return undef;
2514   }
2515
2516   @op=@{$opts{'yopcodes'}};
2517   for $iop (@op) { 
2518     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2519       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2520       return undef;
2521     }
2522     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2523   }
2524
2525 #parameters
2526
2527   if ( !exists $opts{'parm'}) {
2528     $self->{ERRSTR}='transform: no parameter arg given.';
2529     return undef;
2530   }
2531
2532 #  print Dumper(\@ropx);
2533 #  print Dumper(\@ropy);
2534 #  print Dumper(\@ropy);
2535
2536   my $img = Imager->new();
2537   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2538   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2539   return $img;
2540 }
2541
2542
2543 sub transform2 {
2544   my ($opts, @imgs) = @_;
2545   
2546   require "Imager/Expr.pm";
2547
2548   $opts->{variables} = [ qw(x y) ];
2549   my ($width, $height) = @{$opts}{qw(width height)};
2550   if (@imgs) {
2551     my $index = 1;
2552     for my $img (@imgs) {
2553       unless ($img->_valid_image("transform2")) {
2554         Imager->_set_error($img->errstr . " (input image $index)");
2555         return;
2556       }
2557       ++$index;
2558     }
2559
2560     $width ||= $imgs[0]->getwidth();
2561     $height ||= $imgs[0]->getheight();
2562     my $img_num = 1;
2563     for my $img (@imgs) {
2564       $opts->{constants}{"w$img_num"} = $img->getwidth();
2565       $opts->{constants}{"h$img_num"} = $img->getheight();
2566       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2567       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2568       ++$img_num;
2569     }
2570   }
2571   if ($width) {
2572     $opts->{constants}{w} = $width;
2573     $opts->{constants}{cx} = $width/2;
2574   }
2575   else {
2576     $Imager::ERRSTR = "No width supplied";
2577     return;
2578   }
2579   if ($height) {
2580     $opts->{constants}{h} = $height;
2581     $opts->{constants}{cy} = $height/2;
2582   }
2583   else {
2584     $Imager::ERRSTR = "No height supplied";
2585     return;
2586   }
2587   my $code = Imager::Expr->new($opts);
2588   if (!$code) {
2589     $Imager::ERRSTR = Imager::Expr::error();
2590     return;
2591   }
2592   my $channels = $opts->{channels} || 3;
2593   unless ($channels >= 1 && $channels <= 4) {
2594     return Imager->_set_error("channels must be an integer between 1 and 4");
2595   }
2596
2597   my $img = Imager->new();
2598   $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, 
2599                              $channels, $code->code(),
2600                              $code->nregs(), $code->cregs(),
2601                              [ map { $_->{IMG} } @imgs ]);
2602   if (!defined $img->{IMG}) {
2603     $Imager::ERRSTR = Imager->_error_as_msg();
2604     return;
2605   }
2606
2607   return $img;
2608 }
2609
2610 sub rubthrough {
2611   my $self=shift;
2612   my %opts= @_;
2613
2614   $self->_valid_image("rubthrough")
2615     or return;
2616
2617   unless ($opts{src} && $opts{src}->_valid_image("rubthrough")) {
2618     $self->{ERRSTR} = $opts{src}{ERRSTR} . ' (for src)';
2619     return;
2620   }
2621
2622   %opts = (src_minx => 0,
2623            src_miny => 0,
2624            src_maxx => $opts{src}->getwidth(),
2625            src_maxy => $opts{src}->getheight(),
2626            %opts);
2627
2628   my $tx = $opts{tx};
2629   defined $tx or $tx = $opts{left};
2630   defined $tx or $tx = 0;
2631
2632   my $ty = $opts{ty};
2633   defined $ty or $ty = $opts{top};
2634   defined $ty or $ty = 0;
2635
2636   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
2637                     $opts{src_minx}, $opts{src_miny}, 
2638                     $opts{src_maxx}, $opts{src_maxy})) {
2639     $self->_set_error($self->_error_as_msg());
2640     return undef;
2641   }
2642
2643   return $self;
2644 }
2645
2646 sub compose {
2647   my $self = shift;
2648   my %opts =
2649     ( 
2650      opacity => 1.0,
2651      mask_left => 0,
2652      mask_top => 0,
2653      @_
2654     );
2655
2656   $self->_valid_image("compose")
2657     or return;
2658
2659   unless ($opts{src}) {
2660     $self->_set_error("compose: src parameter missing");
2661     return;
2662   }
2663   
2664   unless ($opts{src}->_valid_image("compose")) {
2665     $self->_set_error($opts{src}->errstr . " (for src)");
2666     return;
2667   }
2668   my $src = $opts{src};
2669
2670   my $left = $opts{left};
2671   defined $left or $left = $opts{tx};
2672   defined $left or $left = 0;
2673
2674   my $top = $opts{top};
2675   defined $top or $top = $opts{ty};
2676   defined $top or $top = 0;
2677
2678   my $src_left = $opts{src_left};
2679   defined $src_left or $src_left = $opts{src_minx};
2680   defined $src_left or $src_left = 0;
2681
2682   my $src_top = $opts{src_top};
2683   defined $src_top or $src_top = $opts{src_miny};
2684   defined $src_top or $src_top = 0;
2685
2686   my $width = $opts{width};
2687   if (!defined $width && defined $opts{src_maxx}) {
2688     $width = $opts{src_maxx} - $src_left;
2689   }
2690   defined $width or $width = $src->getwidth() - $src_left;
2691
2692   my $height = $opts{height};
2693   if (!defined $height && defined $opts{src_maxy}) {
2694     $height = $opts{src_maxy} - $src_top;
2695   }
2696   defined $height or $height = $src->getheight() - $src_top;
2697
2698   my $combine = $self->_combine($opts{combine}, 'normal');
2699
2700   if ($opts{mask}) {
2701     unless ($opts{mask}->_valid_image("compose")) {
2702       $self->_set_error($opts{mask}->errstr . " (for mask)");
2703       return;
2704     }
2705
2706     my $mask_left = $opts{mask_left};
2707     defined $mask_left or $mask_left = $opts{mask_minx};
2708     defined $mask_left or $mask_left = 0;
2709     
2710     my $mask_top = $opts{mask_top};
2711     defined $mask_top or $mask_top = $opts{mask_miny};
2712     defined $mask_top or $mask_top = 0;
2713
2714     unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG}, 
2715                    $left, $top, $src_left, $src_top,
2716                    $mask_left, $mask_top, $width, $height, 
2717                            $combine, $opts{opacity})) {
2718       $self->_set_error(Imager->_error_as_msg);
2719       return;
2720     }
2721   }
2722   else {
2723     unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2724                       $width, $height, $combine, $opts{opacity})) {
2725       $self->_set_error(Imager->_error_as_msg);
2726       return;
2727     }
2728   }
2729
2730   return $self;
2731 }
2732
2733 sub flip {
2734   my $self  = shift;
2735   my %opts  = @_;
2736
2737   $self->_valid_image("flip")
2738     or return;
2739
2740   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2741   my $dir;
2742   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2743   $dir = $xlate{$opts{'dir'}};
2744   return $self if i_flipxy($self->{IMG}, $dir);
2745   return ();
2746 }
2747
2748 sub rotate {
2749   my $self = shift;
2750   my %opts = @_;
2751
2752   unless (defined wantarray) {
2753     my @caller = caller;
2754     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2755     return;
2756   }
2757
2758   $self->_valid_image("rotate")
2759     or return;
2760
2761   if (defined $opts{right}) {
2762     my $degrees = $opts{right};
2763     if ($degrees < 0) {
2764       $degrees += 360 * int(((-$degrees)+360)/360);
2765     }
2766     $degrees = $degrees % 360;
2767     if ($degrees == 0) {
2768       return $self->copy();
2769     }
2770     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2771       my $result = Imager->new();
2772       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2773         return $result;
2774       }
2775       else {
2776         $self->{ERRSTR} = $self->_error_as_msg();
2777         return undef;
2778       }
2779     }
2780     else {
2781       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2782       return undef;
2783     }
2784   }
2785   elsif (defined $opts{radians} || defined $opts{degrees}) {
2786     my $amount = $opts{radians} || $opts{degrees} * 3.14159265358979 / 180;
2787
2788     my $back = $opts{back};
2789     my $result = Imager->new;
2790     if ($back) {
2791       $back = _color($back);
2792       unless ($back) {
2793         $self->_set_error(Imager->errstr);
2794         return undef;
2795       }
2796
2797       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2798     }
2799     else {
2800       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2801     }
2802     if ($result->{IMG}) {
2803       return $result;
2804     }
2805     else {
2806       $self->{ERRSTR} = $self->_error_as_msg();
2807       return undef;
2808     }
2809   }
2810   else {
2811     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2812     return undef;
2813   }
2814 }
2815
2816 sub matrix_transform {
2817   my $self = shift;
2818   my %opts = @_;
2819
2820   $self->_valid_image("matrix_transform")
2821     or return;
2822
2823   unless (defined wantarray) {
2824     my @caller = caller;
2825     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2826     return;
2827   }
2828
2829   if ($opts{matrix}) {
2830     my $xsize = $opts{xsize} || $self->getwidth;
2831     my $ysize = $opts{ysize} || $self->getheight;
2832
2833     my $result = Imager->new;
2834     if ($opts{back}) {
2835       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize, 
2836                                           $opts{matrix}, $opts{back})
2837         or return undef;
2838     }
2839     else {
2840       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize, 
2841                                           $opts{matrix})
2842         or return undef;
2843     }
2844
2845     return $result;
2846   }
2847   else {
2848     $self->{ERRSTR} = "matrix parameter required";
2849     return undef;
2850   }
2851 }
2852
2853 # blame Leolo :)
2854 *yatf = \&matrix_transform;
2855
2856 # These two are supported for legacy code only
2857
2858 sub i_color_new {
2859   return Imager::Color->new(@_);
2860 }
2861
2862 sub i_color_set {
2863   return Imager::Color::set(@_);
2864 }
2865
2866 # Draws a box between the specified corner points.
2867 sub box {
2868   my $self=shift;
2869   my $raw = $self->{IMG};
2870
2871   $self->_valid_image("box")
2872     or return;
2873
2874   my %opts = @_;
2875
2876   my ($xmin, $ymin, $xmax, $ymax);
2877   if (exists $opts{'box'}) { 
2878     $xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2879     $xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2880     $ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2881     $ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2882   }
2883   else {
2884     defined($xmin = $opts{xmin}) or $xmin = 0;
2885     defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
2886     defined($ymin = $opts{ymin}) or $ymin = 0;
2887     defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
2888   }
2889
2890   if ($opts{filled}) { 
2891     my $color = $opts{'color'};
2892
2893     if (defined $color) {
2894       unless (_is_color_object($color)) {
2895         $color = _color($color);
2896         unless ($color) { 
2897           $self->{ERRSTR} = $Imager::ERRSTR; 
2898           return;
2899         }
2900       }
2901     }
2902     else {
2903       $color = i_color_new(255,255,255,255);
2904     }
2905
2906     if ($color->isa("Imager::Color")) {
2907       i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
2908     }
2909     else {
2910       i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
2911     }
2912   }
2913   elsif ($opts{fill}) {
2914     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2915       # assume it's a hash ref
2916       require 'Imager/Fill.pm';
2917       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2918         $self->{ERRSTR} = $Imager::ERRSTR;
2919         return undef;
2920       }
2921     }
2922     i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
2923   }
2924   else {
2925     my $color = $opts{'color'};
2926     if (defined $color) {
2927       unless (_is_color_object($color)) {
2928         $color = _color($color);
2929         unless ($color) { 
2930           $self->{ERRSTR} = $Imager::ERRSTR;
2931           return;
2932         }
2933       }
2934     }
2935     else {
2936       $color = i_color_new(255, 255, 255, 255);
2937     }
2938     unless ($color) { 
2939       $self->{ERRSTR} = $Imager::ERRSTR;
2940       return;
2941     }
2942     i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
2943   }
2944
2945   return $self;
2946 }
2947
2948 sub arc {
2949   my $self=shift;
2950
2951   $self->_valid_image("arc")
2952     or return;
2953
2954   my $dflcl= [ 255, 255, 255, 255];
2955   my $good = 1;
2956   my %opts=
2957     (
2958      color=>$dflcl,
2959      'r'=>_min($self->getwidth(),$self->getheight())/3,
2960      'x'=>$self->getwidth()/2,
2961      'y'=>$self->getheight()/2,
2962      'd1'=>0, 'd2'=>361, 
2963      filled => 1,
2964      @_,
2965     );
2966   if ($opts{aa}) {
2967     if ($opts{fill}) {
2968       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2969         # assume it's a hash ref
2970         require 'Imager/Fill.pm';
2971         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2972           $self->{ERRSTR} = $Imager::ERRSTR;
2973           return;
2974         }
2975       }
2976       if ($opts{d1} == 0 && $opts{d2} == 361) {
2977         i_circle_aa_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2978                          $opts{fill}{fill});
2979       }
2980       else {
2981         i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2982                        $opts{'d2'}, $opts{fill}{fill});
2983       }
2984     }
2985     elsif ($opts{filled}) {
2986       my $color = _color($opts{'color'});
2987       unless ($color) { 
2988         $self->{ERRSTR} = $Imager::ERRSTR; 
2989         return; 
2990       }
2991       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2992         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, 
2993                     $color);
2994       }
2995       else {
2996         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2997                  $opts{'d1'}, $opts{'d2'}, $color); 
2998       }
2999     }
3000     else {
3001       my $color = _color($opts{'color'});
3002       if ($opts{d2} - $opts{d1} >= 360) {
3003         $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
3004       }
3005       else {
3006         $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
3007       }
3008     }
3009   }
3010   else {
3011     if ($opts{fill}) {
3012       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3013         # assume it's a hash ref
3014         require 'Imager/Fill.pm';
3015         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3016           $self->{ERRSTR} = $Imager::ERRSTR;
3017           return;
3018         }
3019       }
3020       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
3021                   $opts{'d2'}, $opts{fill}{fill});
3022     }
3023     else {
3024       my $color = _color($opts{'color'});
3025       unless ($color) { 
3026         $self->{ERRSTR} = $Imager::ERRSTR; 
3027         return;
3028       }
3029       if ($opts{filled}) {
3030         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
3031               $opts{'d1'}, $opts{'d2'}, $color); 
3032       }
3033       else {
3034         if ($opts{d1} == 0 && $opts{d2} == 361) {
3035           $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
3036         }
3037         else {
3038           $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
3039         }
3040       }
3041     }
3042   }
3043   unless ($good) {
3044     $self->_set_error($self->_error_as_msg);
3045     return;
3046   }
3047
3048   return $self;
3049 }
3050
3051 # Draws a line from one point to the other
3052 # the endpoint is set if the endp parameter is set which it is by default.
3053 # to turn of the endpoint being set use endp=>0 when calling line.
3054
3055 sub line {
3056   my $self=shift;
3057   my $dflcl=i_color_new(0,0,0,0);
3058   my %opts=(color=>$dflcl,
3059             endp => 1,
3060             @_);
3061
3062   $self->_valid_image("line")
3063     or return;
3064
3065   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
3066   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
3067
3068   my $color = _color($opts{'color'});
3069   unless ($color) {
3070     $self->{ERRSTR} = $Imager::ERRSTR;
3071     return;
3072   }
3073
3074   $opts{antialias} = $opts{aa} if defined $opts{aa};
3075   if ($opts{antialias}) {
3076     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
3077               $color, $opts{endp});
3078   } else {
3079     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
3080            $color, $opts{endp});
3081   }
3082   return $self;
3083 }
3084
3085 # Draws a line between an ordered set of points - It more or less just transforms this
3086 # into a list of lines.
3087
3088 sub polyline {
3089   my $self=shift;
3090   my ($pt,$ls,@points);
3091   my $dflcl=i_color_new(0,0,0,0);
3092   my %opts=(color=>$dflcl,@_);
3093
3094   $self->_valid_image("polyline")
3095     or return;
3096
3097   if (exists($opts{points})) { @points=@{$opts{points}}; }
3098   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
3099     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
3100     }
3101
3102 #  print Dumper(\@points);
3103
3104   my $color = _color($opts{'color'});
3105   unless ($color) { 
3106     $self->{ERRSTR} = $Imager::ERRSTR; 
3107     return; 
3108   }
3109   $opts{antialias} = $opts{aa} if defined $opts{aa};
3110   if ($opts{antialias}) {
3111     for $pt(@points) {
3112       if (defined($ls)) { 
3113         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3114       }
3115       $ls=$pt;
3116     }
3117   } else {
3118     for $pt(@points) {
3119       if (defined($ls)) { 
3120         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3121       }
3122       $ls=$pt;
3123     }
3124   }
3125   return $self;
3126 }
3127
3128 sub polygon {
3129   my $self = shift;
3130   my ($pt,$ls,@points);
3131   my $dflcl = i_color_new(0,0,0,0);
3132   my %opts = (color=>$dflcl, @_);
3133
3134   $self->_valid_image("polygon")
3135     or return;
3136
3137   if (exists($opts{points})) {
3138     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
3139     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
3140   }
3141
3142   if (!exists $opts{'x'} or !exists $opts{'y'})  {
3143     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
3144   }
3145
3146   my $mode = _first($opts{mode}, 0);
3147
3148   if ($opts{'fill'}) {
3149     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
3150       # assume it's a hash ref
3151       require 'Imager/Fill.pm';
3152       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
3153         $self->{ERRSTR} = $Imager::ERRSTR;
3154         return undef;
3155       }
3156     }
3157     unless (i_poly_aa_cfill_m($self->{IMG}, $opts{'x'}, $opts{'y'},
3158                               $mode, $opts{'fill'}{'fill'})) {
3159       return $self->_set_error($self->_error_as_msg);
3160     }
3161   }
3162   else {
3163     my $color = _color($opts{'color'});
3164     unless ($color) { 
3165       $self->{ERRSTR} = $Imager::ERRSTR; 
3166       return;
3167     }
3168     unless (i_poly_aa_m($self->{IMG}, $opts{'x'}, $opts{'y'}, $mode, $color)) {
3169       return $self->_set_error($self->_error_as_msg);
3170     }
3171   }
3172
3173   return $self;
3174 }
3175
3176 sub polypolygon {
3177   my ($self, %opts) = @_;
3178
3179   $self->_valid_image("polypolygon")
3180     or return;
3181
3182   my $points = $opts{points};
3183   $points
3184     or return $self->_set_error("polypolygon: missing required points");
3185
3186   my $mode = _first($opts{mode}, "evenodd");
3187
3188   if ($opts{filled}) {
3189     my $color = _color(_first($opts{color}, [ 0, 0, 0, 0 ]))
3190       or return $self->_set_error($Imager::ERRSTR);
3191
3192     i_poly_poly_aa($self->{IMG}, $points, $mode, $color)
3193       or return $self->_set_error($self->_error_as_msg);
3194   }
3195   elsif ($opts{fill}) {
3196     my $fill = $opts{fill};
3197     $self->_valid_fill($fill, "polypolygon")
3198       or return;
3199
3200     i_poly_poly_aa_cfill($self->{IMG}, $points, $mode, $fill->{fill})
3201       or return $self->_set_error($self->_error_as_msg);
3202   }
3203   else {
3204     my $color = _color(_first($opts{color}, [ 0, 0, 0, 255 ]))
3205       or return $self->_set_error($Imager::ERRSTR);
3206
3207     my $rimg = $self->{IMG};
3208
3209     if (_first($opts{aa}, 1)) {
3210       for my $poly (@$points) {
3211         my $xp = $poly->[0];
3212         my $yp = $poly->[1];
3213         for my $i (0 .. $#$xp - 1) {
3214           i_line_aa($rimg, $xp->[$i], $yp->[$i], $xp->[$i+1], $yp->[$i+1],
3215                     $color, 0);
3216         }
3217         i_line_aa($rimg, $xp->[$#$xp], $yp->[$#$yp], $xp->[0], $yp->[0],
3218                   $color, 0);
3219       }
3220     }
3221     else {
3222       for my $poly (@$points) {
3223         my $xp = $poly->[0];
3224         my $yp = $poly->[1];
3225         for my $i (0 .. $#$xp - 1) {
3226           i_line($rimg, $xp->[$i], $yp->[$i], $xp->[$i+1], $yp->[$i+1],
3227                  $color, 0);
3228         }
3229         i_line($rimg, $xp->[$#$xp], $yp->[$#$yp], $xp->[0], $yp->[0],
3230                $color, 0);
3231       }
3232     }
3233   }
3234
3235   return $self;
3236 }
3237
3238 # this the multipoint bezier curve
3239 # this is here more for testing that actual usage since
3240 # this is not a good algorithm.  Usually the curve would be
3241 # broken into smaller segments and each done individually.
3242
3243 sub polybezier {
3244   my $self=shift;
3245   my ($pt,$ls,@points);
3246   my $dflcl=i_color_new(0,0,0,0);
3247   my %opts=(color=>$dflcl,@_);
3248
3249   $self->_valid_image("polybezier")
3250     or return;
3251
3252   if (exists $opts{points}) {
3253     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
3254     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
3255   }
3256
3257   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
3258     $self->{ERRSTR}='Missing or invalid points.';
3259     return;
3260   }
3261
3262   my $color = _color($opts{'color'});
3263   unless ($color) { 
3264     $self->{ERRSTR} = $Imager::ERRSTR; 
3265     return; 
3266   }
3267   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
3268   return $self;
3269 }
3270
3271 sub flood_fill {
3272   my $self = shift;
3273   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
3274   my $rc;
3275
3276   $self->_valid_image("flood_fill")
3277     or return;
3278
3279   unless (exists $opts{'x'} && exists $opts{'y'}) {
3280     $self->{ERRSTR} = "missing seed x and y parameters";
3281     return undef;
3282   }
3283
3284   if ($opts{border}) {
3285     my $border = _color($opts{border});
3286     unless ($border) {
3287       $self->_set_error($Imager::ERRSTR);
3288       return;
3289     }
3290     if ($opts{fill}) {
3291       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3292         # assume it's a hash ref
3293         require Imager::Fill;
3294         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3295           $self->{ERRSTR} = $Imager::ERRSTR;
3296           return;
3297         }
3298       }
3299       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'}, 
3300                                  $opts{fill}{fill}, $border);
3301     }
3302     else {
3303       my $color = _color($opts{'color'});
3304       unless ($color) {
3305         $self->{ERRSTR} = $Imager::ERRSTR;
3306         return;
3307       }
3308       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'}, 
3309                                 $color, $border);
3310     }
3311     if ($rc) { 
3312       return $self; 
3313     } 
3314     else { 
3315       $self->{ERRSTR} = $self->_error_as_msg(); 
3316       return;
3317     }
3318   }
3319   else {
3320     if ($opts{fill}) {
3321       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3322         # assume it's a hash ref
3323         require 'Imager/Fill.pm';
3324         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3325           $self->{ERRSTR} = $Imager::ERRSTR;
3326           return;
3327         }
3328       }
3329       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3330     }
3331     else {
3332       my $color = _color($opts{'color'});
3333       unless ($color) {
3334         $self->{ERRSTR} = $Imager::ERRSTR;
3335         return;
3336       }
3337       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3338     }
3339     if ($rc) { 
3340       return $self; 
3341     } 
3342     else { 
3343       $self->{ERRSTR} = $self->_error_as_msg(); 
3344       return;
3345     }
3346   } 
3347 }
3348
3349 sub setpixel {
3350   my ($self, %opts) = @_;
3351
3352   $self->_valid_image("setpixel")
3353     or return;
3354
3355   my $color = $opts{color};
3356   unless (defined $color) {
3357     $color = $self->{fg};
3358     defined $color or $color = NC(255, 255, 255);
3359   }
3360
3361   unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3362     unless ($color = _color($color, 'setpixel')) {
3363       $self->_set_error("setpixel: " . Imager->errstr);
3364       return;
3365     }
3366   }
3367
3368   unless (exists $opts{'x'} && exists $opts{'y'}) {
3369     $self->_set_error('setpixel: missing x or y parameter');
3370     return;
3371   }
3372
3373   my $x = $opts{'x'};
3374   my $y = $opts{'y'};
3375   if (ref $x || ref $y) {
3376     $x = ref $x ? $x : [ $x ];
3377     $y = ref $y ? $y : [ $y ];
3378     unless (@$x) {
3379       $self->_set_error("setpixel: x is a reference to an empty array");
3380       return;
3381     }
3382     unless (@$y) {
3383       $self->_set_error("setpixel: y is a reference to an empty array");
3384       return;
3385     }
3386
3387     # make both the same length, replicating the last element
3388     if (@$x < @$y) {
3389       $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3390     }
3391     elsif (@$y < @$x) {
3392       $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3393     }
3394
3395     my $set = 0;
3396     if ($color->isa('Imager::Color')) {
3397       for my $i (0..$#$x) {
3398         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3399           or ++$set;
3400       }
3401     }
3402     else {
3403       for my $i (0..$#$x) {
3404         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3405           or ++$set;
3406       }
3407     }
3408
3409     return $set;
3410   }
3411   else {
3412     if ($color->isa('Imager::Color')) {
3413       i_ppix($self->{IMG}, $x, $y, $color)
3414         and return "0 but true";
3415     }
3416     else {
3417       i_ppixf($self->{IMG}, $x, $y, $color)
3418         and return "0 but true";
3419     }
3420
3421     return 1;
3422   }
3423 }
3424
3425 sub getpixel {
3426   my $self = shift;
3427
3428   my %opts = ( "type"=>'8bit', @_);
3429
3430   $self->_valid_image("getpixel")
3431     or return;
3432
3433   unless (exists $opts{'x'} && exists $opts{'y'}) {
3434     $self->_set_error('getpixel: missing x or y parameter');
3435     return;
3436   }
3437
3438   my $x = $opts{'x'};
3439   my $y = $opts{'y'};
3440   my $type = $opts{'type'};
3441   if (ref $x || ref $y) {
3442     $x = ref $x ? $x : [ $x ];
3443     $y = ref $y ? $y : [ $y ];
3444     unless (@$x) {
3445       $self->_set_error("getpixel: x is a reference to an empty array");
3446       return;
3447     }
3448     unless (@$y) {
3449       $self->_set_error("getpixel: y is a reference to an empty array");
3450       return;
3451     }
3452
3453     # make both the same length, replicating the last element
3454     if (@$x < @$y) {
3455       $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3456     }
3457     elsif (@$y < @$x) {
3458       $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3459     }
3460
3461     my @result;
3462     if ($type eq '8bit') {
3463       for my $i (0..$#$x) {
3464         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3465       }
3466     }
3467     elsif ($type eq 'float' || $type eq 'double') {
3468       for my $i (0..$#$x) {
3469         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3470       }
3471     }
3472     else {
3473       $self->_set_error("getpixel: type must be '8bit' or 'float'");
3474       return;
3475     }
3476     return wantarray ? @result : \@result;
3477   }
3478   else {
3479     if ($type eq '8bit') {
3480       return i_get_pixel($self->{IMG}, $x, $y);
3481     }
3482     elsif ($type eq 'float' || $type eq 'double') {
3483       return i_gpixf($self->{IMG}, $x, $y);
3484     }
3485     else {
3486       $self->_set_error("getpixel: type must be '8bit' or 'float'");
3487       return;
3488     }
3489   }
3490 }
3491
3492 sub getscanline {
3493   my $self = shift;
3494   my %opts = ( type => '8bit', x=>0, @_);
3495
3496   $self->_valid_image("getscanline")
3497     or return;
3498
3499   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3500
3501   unless (defined $opts{'y'}) {
3502     $self->_set_error("missing y parameter");
3503     return;
3504   }
3505
3506   if ($opts{type} eq '8bit') {
3507     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3508                   $opts{'y'});
3509   }
3510   elsif ($opts{type} eq 'float') {
3511     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3512                   $opts{'y'});
3513   }
3514   elsif ($opts{type} eq 'index') {
3515     unless (i_img_type($self->{IMG})) {
3516       $self->_set_error("type => index only valid on paletted images");
3517       return;
3518     }
3519     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3520                   $opts{'y'});
3521   }
3522   else {
3523     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3524     return;
3525   }
3526 }
3527
3528 sub setscanline {
3529   my $self = shift;
3530   my %opts = ( x=>0, @_);
3531
3532   $self->_valid_image("setscanline")
3533     or return;
3534
3535   unless (defined $opts{'y'}) {
3536     $self->_set_error("missing y parameter");
3537     return;
3538   }
3539
3540   if (!$opts{type}) {
3541     if (ref $opts{pixels} && @{$opts{pixels}}) {
3542       # try to guess the type
3543       if ($opts{pixels}[0]->isa('Imager::Color')) {
3544         $opts{type} = '8bit';
3545       }
3546       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3547         $opts{type} = 'float';
3548       }
3549       else {
3550         $self->_set_error("missing type parameter and could not guess from pixels");
3551         return;
3552       }
3553     }
3554     else {
3555       # default
3556       $opts{type} = '8bit';
3557     }
3558   }
3559
3560   if ($opts{type} eq '8bit') {
3561     if (ref $opts{pixels}) {
3562       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3563     }
3564     else {
3565       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3566     }
3567   }
3568   elsif ($opts{type} eq 'float') {
3569     if (ref $opts{pixels}) {
3570       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3571     }
3572     else {
3573       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3574     }
3575   }
3576   elsif ($opts{type} eq 'index') {
3577     if (ref $opts{pixels}) {
3578       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3579     }
3580     else {
3581       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3582     }
3583   }
3584   else {
3585     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3586     return;
3587   }
3588 }
3589
3590 sub getsamples {
3591   my $self = shift;
3592   my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3593
3594   $self->_valid_image("getsamples")
3595     or return;
3596
3597   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3598
3599   unless (defined $opts{'y'}) {
3600     $self->_set_error("missing y parameter");
3601     return;
3602   }
3603   
3604   if ($opts{target}) {
3605     my $target = $opts{target};
3606     my $offset = $opts{offset};
3607     if ($opts{type} eq '8bit') {
3608       my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3609                             $opts{y}, $opts{channels})
3610         or return;
3611       @{$target}[$offset .. $offset + @samples - 1] = @samples;
3612       return scalar(@samples);
3613     }
3614     elsif ($opts{type} eq 'float') {
3615       my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3616                              $opts{y}, $opts{channels});
3617       @{$target}[$offset .. $offset + @samples - 1] = @samples;
3618       return scalar(@samples);
3619     }
3620     elsif ($opts{type} =~ /^(\d+)bit$/) {
3621       my $bits = $1;
3622
3623       my @data;
3624       my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width}, 
3625                                $opts{y}, $bits, $target, 
3626                                $offset, $opts{channels});
3627       unless (defined $count) {
3628         $self->_set_error(Imager->_error_as_msg);
3629         return;
3630       }
3631
3632       return $count;
3633     }
3634     else {
3635       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3636       return;
3637     }
3638   }
3639   else {
3640     if ($opts{type} eq '8bit') {
3641       return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3642                      $opts{y}, $opts{channels});
3643     }
3644     elsif ($opts{type} eq 'float') {
3645       return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3646                       $opts{y}, $opts{channels});
3647     }
3648     elsif ($opts{type} =~ /^(\d+)bit$/) {
3649       my $bits = $1;
3650
3651       my @data;
3652       i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width}, 
3653                    $opts{y}, $bits, \@data, 0, $opts{channels})
3654         or return;
3655       return @data;
3656     }
3657     else {
3658       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3659       return;
3660     }
3661   }
3662 }
3663
3664 sub setsamples {
3665   my $self = shift;
3666
3667   $self->_valid_image("setsamples")
3668     or return;
3669
3670   my %opts = ( x => 0, offset => 0 );
3671   my $data_index;
3672   # avoid duplicating the data parameter, it may be a large scalar
3673   my $i = 0;
3674   while ($i < @_ -1) {
3675     if ($_[$i] eq 'data') {
3676       $data_index = $i+1;
3677     }
3678     else {
3679       $opts{$_[$i]} = $_[$i+1];
3680     }
3681
3682     $i += 2;
3683   }
3684
3685   unless(defined $data_index) {
3686     $self->_set_error('setsamples: data parameter missing');
3687     return;
3688   }
3689   unless (defined $_[$data_index]) {
3690     $self->_set_error('setsamples: data parameter not defined');
3691     return;
3692   }
3693
3694   my $type = $opts{type};
3695   defined $type or $type = '8bit';
3696
3697   my $width = defined $opts{width} ? $opts{width}
3698     : $self->getwidth() - $opts{x};
3699
3700   my $count;
3701   if ($type eq '8bit') {
3702     $count = i_psamp($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3703                      $_[$data_index], $opts{offset}, $width);
3704   }
3705   elsif ($type eq 'float') {
3706     $count = i_psampf($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3707                       $_[$data_index], $opts{offset}, $width);
3708   }
3709   elsif ($type =~ /^([0-9]+)bit$/) {
3710     my $bits = $1;
3711
3712     unless (ref $_[$data_index]) {
3713       $self->_set_error("setsamples: data must be an array ref for type not 8bit or float");
3714       return;
3715     }
3716
3717     $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3718                           $opts{channels}, $_[$data_index], $opts{offset}, 
3719                           $width);
3720   }
3721   else {
3722     $self->_set_error('setsamples: type parameter invalid');
3723     return;
3724   }
3725
3726   unless (defined $count) {
3727     $self->_set_error(Imager->_error_as_msg);
3728     return;
3729   }
3730
3731   return $count;
3732 }
3733
3734 # make an identity matrix of the given size
3735 sub _identity {
3736   my ($size) = @_;
3737
3738   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3739   for my $c (0 .. ($size-1)) {
3740     $matrix->[$c][$c] = 1;
3741   }
3742   return $matrix;
3743 }
3744
3745 # general function to convert an image
3746 sub convert {
3747   my ($self, %opts) = @_;
3748   my $matrix;
3749
3750   $self->_valid_image("convert")
3751     or return;
3752
3753   unless (defined wantarray) {
3754     my @caller = caller;
3755     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3756     return;
3757   }
3758
3759   # the user can either specify a matrix or preset
3760   # the matrix overrides the preset
3761   if (!exists($opts{matrix})) {
3762     unless (exists($opts{preset})) {
3763       $self->{ERRSTR} = "convert() needs a matrix or preset";
3764       return;
3765     }
3766     else {
3767       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3768         # convert to greyscale, keeping the alpha channel if any
3769         if ($self->getchannels == 3) {
3770           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3771         }
3772         elsif ($self->getchannels == 4) {
3773           # preserve the alpha channel
3774           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3775                       [ 0,     0,     0,     1 ] ];
3776         }
3777         else {
3778           # an identity
3779           $matrix = _identity($self->getchannels);
3780         }
3781       }
3782       elsif ($opts{preset} eq 'noalpha') {
3783         # strip the alpha channel
3784         if ($self->getchannels == 2 or $self->getchannels == 4) {
3785           $matrix = _identity($self->getchannels);
3786           pop(@$matrix); # lose the alpha entry
3787         }
3788         else {
3789           $matrix = _identity($self->getchannels);
3790         }
3791       }
3792       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3793         # extract channel 0
3794         $matrix = [ [ 1 ] ];
3795       }
3796       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3797         $matrix = [ [ 0, 1 ] ];
3798       }
3799       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3800         $matrix = [ [ 0, 0, 1 ] ];
3801       }
3802       elsif ($opts{preset} eq 'alpha') {
3803         if ($self->getchannels == 2 or $self->getchannels == 4) {
3804           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3805         }
3806         else {
3807           # the alpha is just 1 <shrug>
3808           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3809         }
3810       }
3811       elsif ($opts{preset} eq 'rgb') {
3812         if ($self->getchannels == 1) {
3813           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3814         }
3815         elsif ($self->getchannels == 2) {
3816           # preserve the alpha channel
3817           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3818         }
3819         else {
3820           $matrix = _identity($self->getchannels);
3821         }
3822       }
3823       elsif ($opts{preset} eq 'addalpha') {
3824         if ($self->getchannels == 1) {
3825           $matrix = _identity(2);
3826         }
3827         elsif ($self->getchannels == 3) {
3828           $matrix = _identity(4);
3829         }
3830         else {
3831           $matrix = _identity($self->getchannels);
3832         }
3833       }
3834       else {
3835         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3836         return undef;
3837       }
3838     }
3839   }
3840   else {
3841     $matrix = $opts{matrix};
3842   }
3843
3844   my $new = Imager->new;
3845   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3846   unless ($new->{IMG}) {
3847     # most likely a bad matrix
3848     i_push_error(0, "convert");
3849     $self->{ERRSTR} = _error_as_msg();
3850     return undef;
3851   }
3852   return $new;
3853 }
3854
3855 # combine channels from multiple input images, a class method
3856 sub combine {
3857   my ($class, %opts) = @_;
3858
3859   my $src = delete $opts{src};
3860   unless ($src) {
3861     $class->_set_error("src parameter missing");
3862     return;
3863   }
3864   my @imgs;
3865   my $index = 0;
3866   for my $img (@$src) {
3867     unless (eval { $img->isa("Imager") }) {
3868       $class->_set_error("src must contain image objects");
3869       return;
3870     }
3871     unless ($img->_valid_image("combine")) {
3872       $Imager::ERRSTR = $img->{ERRSTR} . " (src->[$index])";
3873       return;
3874     }
3875     push @imgs, $img->{IMG};
3876   }
3877   my $result;
3878   if (my $channels = delete $opts{channels}) {
3879     $result = i_combine(\@imgs, $channels);
3880   }
3881   else {
3882     $result = i_combine(\@imgs);
3883   }
3884   unless ($result) {
3885     $class->_set_error($class->_error_as_msg);
3886     return;
3887   }
3888
3889   my $img = $class->new;
3890   $img->{IMG} = $result;
3891
3892   return $img;
3893 }
3894
3895
3896 # general function to map an image through lookup tables
3897
3898 sub map {
3899   my ($self, %opts) = @_;
3900   my @chlist = qw( red green blue alpha );
3901
3902   $self->_valid_image("map")
3903     or return;
3904
3905   if (!exists($opts{'maps'})) {
3906     # make maps from channel maps
3907     my $chnum;
3908     for $chnum (0..$#chlist) {
3909       if (exists $opts{$chlist[$chnum]}) {
3910         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3911       } elsif (exists $opts{'all'}) {
3912         $opts{'maps'}[$chnum] = $opts{'all'};
3913       }
3914     }
3915   }
3916   if ($opts{'maps'} and $self->{IMG}) {
3917     i_map($self->{IMG}, $opts{'maps'} );
3918   }
3919   return $self;
3920 }
3921
3922 sub difference {
3923   my ($self, %opts) = @_;
3924
3925   $self->_valid_image("difference")
3926     or return;
3927
3928   defined $opts{mindist} or $opts{mindist} = 0;
3929
3930   defined $opts{other}
3931     or return $self->_set_error("No 'other' parameter supplied");
3932   unless ($opts{other}->_valid_image("difference")) {
3933     $self->_set_error($opts{other}->errstr . " (other image)");
3934     return;
3935   }
3936
3937   my $result = Imager->new;
3938   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG}, 
3939                                 $opts{mindist})
3940     or return $self->_set_error($self->_error_as_msg());
3941
3942   return $result;
3943 }
3944
3945 # destructive border - image is shrunk by one pixel all around
3946
3947 sub border {
3948   my ($self,%opts)=@_;
3949   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3950   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3951 }
3952
3953
3954 # Get the width of an image
3955
3956 sub getwidth {
3957   my $self = shift;
3958
3959   $self->_valid_image("getwidth")
3960     or return;
3961
3962   return i_img_get_width($self->{IMG});
3963 }
3964
3965 # Get the height of an image
3966
3967 sub getheight {
3968   my $self = shift;
3969
3970   $self->_valid_image("getheight")
3971     or return;
3972
3973   return i_img_get_height($self->{IMG});
3974 }
3975
3976 # Get number of channels in an image
3977
3978 sub getchannels {
3979   my $self = shift;
3980
3981   $self->_valid_image("getchannels")
3982     or return;
3983
3984   return i_img_getchannels($self->{IMG});
3985 }
3986
3987 my @model_names = qw(unknown gray graya rgb rgba);
3988
3989 sub colormodel {
3990   my ($self, %opts) = @_;
3991
3992   $self->_valid_image("colormodel")
3993     or return;
3994
3995   my $model = i_img_color_model($self->{IMG});
3996
3997   return $opts{numeric} ? $model : $model_names[$model];
3998 }
3999
4000 sub colorchannels {
4001   my ($self) = @_;
4002
4003   $self->_valid_image("colorchannels")
4004     or return;
4005
4006   return i_img_color_channels($self->{IMG});
4007 }
4008
4009 sub alphachannel {
4010   my ($self) = @_;
4011
4012   $self->_valid_image("alphachannel")
4013     or return;
4014
4015   return scalar(i_img_alpha_channel($self->{IMG}));
4016 }
4017
4018 # Get channel mask
4019
4020 sub getmask {
4021   my $self = shift;
4022
4023   $self->_valid_image("getmask")
4024     or return;
4025
4026   return i_img_getmask($self->{IMG});
4027 }
4028
4029 # Set channel mask
4030
4031 sub setmask {
4032   my $self = shift;
4033   my %opts = @_;
4034
4035   $self->_valid_image("setmask")
4036     or return;
4037
4038   unless (defined $opts{mask}) {
4039     $self->_set_error("mask parameter required");
4040     return;
4041   }
4042
4043   i_img_setmask( $self->{IMG} , $opts{mask} );
4044
4045   1;
4046 }
4047
4048 # Get number of colors in an image
4049
4050 sub getcolorcount {
4051   my $self=shift;
4052   my %opts=('maxcolors'=>2**30,@_);
4053
4054   $self->_valid_image("getcolorcount")
4055     or return;
4056
4057   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
4058   return ($rc==-1? undef : $rc);
4059 }
4060
4061 # Returns a reference to a hash. The keys are colour named (packed) and the
4062 # values are the number of pixels in this colour.
4063 sub getcolorusagehash {
4064   my $self = shift;
4065
4066   $self->_valid_image("getcolorusagehash")
4067     or return;
4068
4069   my %opts = ( maxcolors => 2**30, @_ );
4070   my $max_colors = $opts{maxcolors};
4071   unless (defined $max_colors && $max_colors > 0) {
4072     $self->_set_error('maxcolors must be a positive integer');
4073     return;
4074   }
4075
4076   my $channels= $self->getchannels;
4077   # We don't want to look at the alpha channel, because some gifs using it
4078   # doesn't define it for every colour (but only for some)
4079   $channels -= 1 if $channels == 2 or $channels == 4;
4080   my %color_use;
4081   my $height = $self->getheight;
4082   for my $y (0 .. $height - 1) {
4083     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
4084     while (length $colors) {
4085       $color_use{ substr($colors, 0, $channels, '') }++;
4086     }
4087     keys %color_use > $max_colors
4088       and return;
4089   }
4090   return \%color_use;
4091 }
4092
4093 # This will return a ordered array of the colour usage. Kind of the sorted
4094 # version of the values of the hash returned by getcolorusagehash.
4095 # You might want to add safety checks and change the names, etc...
4096 sub getcolorusage {
4097   my $self = shift;
4098
4099   $self->_valid_image("getcolorusage")
4100     or return;
4101
4102   my %opts = ( maxcolors => 2**30, @_ );
4103   my $max_colors = $opts{maxcolors};
4104   unless (defined $max_colors && $max_colors > 0) {
4105     $self->_set_error('maxcolors must be a positive integer');
4106     return;
4107   }
4108
4109   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
4110 }
4111
4112 # draw string to an image
4113
4114 sub string {
4115   my $self = shift;
4116
4117   $self->_valid_image("string")
4118     or return;
4119
4120   my %input=('x'=>0, 'y'=>0, @_);
4121   defined($input{string}) or $input{string} = $input{text};
4122
4123   unless(defined $input{string}) {
4124     $self->{ERRSTR}="missing required parameter 'string'";
4125     return;
4126   }
4127
4128   unless($input{font}) {
4129     $self->{ERRSTR}="missing required parameter 'font'";
4130     return;
4131   }
4132
4133   unless ($input{font}->draw(image=>$self, %input)) {
4134     return;
4135   }
4136
4137   return $self;
4138 }
4139
4140 sub align_string {
4141   my $self = shift;
4142
4143   my $img;
4144   if (ref $self) {
4145     $self->_valid_image("align_string")
4146       or return;
4147
4148     $img = $self;
4149   }
4150   else {
4151     $img = undef;
4152   }
4153
4154   my %input=('x'=>0, 'y'=>0, @_);
4155   defined $input{string}
4156     or $input{string} = $input{text};
4157
4158   unless(exists $input{string}) {
4159     $self->_set_error("missing required parameter 'string'");
4160     return;
4161   }
4162
4163   unless($input{font}) {
4164     $self->_set_error("missing required parameter 'font'");
4165     return;
4166   }
4167
4168   my @result;
4169   unless (@result = $input{font}->align(image=>$img, %input)) {
4170     return;
4171   }
4172
4173   return wantarray ? @result : $result[0];
4174 }
4175
4176 my @file_limit_names = qw/width height bytes/;
4177
4178 sub set_file_limits {
4179   shift;
4180
4181   my %opts = @_;
4182   my %values;
4183   
4184   if ($opts{reset}) {
4185     @values{@file_limit_names} = (0) x @file_limit_names;
4186   }
4187   else {
4188     @values{@file_limit_names} = i_get_image_file_limits();
4189   }
4190
4191   for my $key (keys %values) {
4192     defined $opts{$key} and $values{$key} = $opts{$key};
4193   }
4194
4195   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
4196 }
4197
4198 sub get_file_limits {
4199   i_get_image_file_limits();
4200 }
4201
4202 my @check_args = qw(width height channels sample_size);
4203
4204 sub check_file_limits {
4205   my $class = shift;
4206
4207   my %opts =
4208     (
4209      channels => 3,
4210      sample_size => 1,
4211      @_,
4212     );
4213
4214   if ($opts{sample_size} && $opts{sample_size} eq 'float') {
4215     $opts{sample_size} = length(pack("d", 0));
4216   }
4217
4218   for my $name (@check_args) {
4219     unless (defined $opts{$name}) {
4220       $class->_set_error("check_file_limits: $name must be defined");
4221       return;
4222     }
4223     unless ($opts{$name} == int($opts{$name})) {
4224       $class->_set_error("check_file_limits: $name must be a positive integer");
4225       return;
4226     }
4227   }
4228
4229   my $result = i_int_check_image_file_limits(@opts{@check_args});
4230   unless ($result) {
4231     $class->_set_error($class->_error_as_msg());
4232   }
4233
4234   return $result;
4235 }
4236
4237 # Shortcuts that can be exported
4238
4239 sub newcolor { Imager::Color->new(@_); }
4240 sub newfont  { Imager::Font->new(@_); }
4241 sub NCF {
4242   require Imager::Color::Float;
4243   return Imager::Color::Float->new(@_);
4244 }
4245
4246 *NC=*newcolour=*newcolor;
4247 *NF=*newfont;
4248
4249 *open=\&read;
4250 *circle=\&arc;
4251
4252
4253 #### Utility routines
4254
4255 sub errstr { 
4256   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
4257 }
4258
4259 sub _set_error {
4260   my ($self, $msg) = @_;
4261
4262   if (ref $self) {
4263     $self->{ERRSTR} = $msg;
4264   }
4265   else {
4266     $ERRSTR = $msg;
4267   }
4268   return;
4269 }
4270
4271 # Default guess for the type of an image from extension
4272
4273 my @simple_types = qw(png tga gif raw ico cur xpm mng jng ilbm pcx psd eps webp xwd xpm dng ras);
4274
4275 my %ext_types =
4276   (
4277    ( map { $_ => $_ } @simple_types ),
4278    tiff => "tiff",
4279    tif => "tiff",
4280    pbm => "pnm",
4281    pgm => "pnm",
4282    ppm => "pnm",
4283    pnm => "pnm", # technically wrong, but historically it works in Imager
4284    jpeg => "jpeg",
4285    jpg => "jpeg",
4286    bmp => "bmp",
4287    dib => "bmp",
4288    rgb => "sgi",
4289    bw => "sgi",
4290    sgi => "sgi",
4291    fit => "fits",
4292    fits => "fits",
4293    rle => "utah",
4294   );
4295
4296 sub def_guess_type {
4297   my $name=lc(shift);
4298
4299   my ($ext) = $name =~ /\.([^.]+)$/
4300     or return;
4301
4302   my $type = $ext_types{$ext}
4303     or return;
4304
4305   return $type;
4306 }
4307
4308 sub add_type_extensions {
4309   my ($class, $type, @exts) = @_;
4310
4311   for my $ext (@exts) {
4312     exists $ext_types{lc $ext} or $ext_types{lc $ext} = lc $type;
4313   }
4314   1;
4315 }
4316
4317 sub combines {
4318   return @combine_types;
4319 }
4320
4321 # get the minimum of a list
4322
4323 sub _min {
4324   my $mx=shift;
4325   for(@_) { if ($_<$mx) { $mx=$_; }}
4326   return $mx;
4327 }
4328
4329 # get the maximum of a list
4330
4331 sub _max {
4332   my $mx=shift;
4333   for(@_) { if ($_>$mx) { $mx=$_; }}
4334   return $mx;
4335 }
4336
4337 # string stuff for iptc headers
4338
4339 sub _clean {
4340   my($str)=$_[0];
4341   $str = substr($str,3);
4342   $str =~ s/[\n\r]//g;
4343   $str =~ s/\s+/ /g;
4344   $str =~ s/^\s//;
4345   $str =~ s/\s$//;
4346   return $str;
4347 }
4348
4349 # A little hack to parse iptc headers.
4350
4351 sub parseiptc {
4352   my $self=shift;
4353   my(@sar,$item,@ar);
4354   my($caption,$photogr,$headln,$credit);
4355
4356   my $str=$self->{IPTCRAW};
4357
4358   defined $str
4359     or return;
4360
4361   @ar=split(/8BIM/,$str);
4362
4363   my $i=0;
4364   foreach (@ar) {
4365     if (/^\004\004/) {
4366       @sar=split(/\034\002/);
4367       foreach $item (@sar) {
4368         if ($item =~ m/^x/) {
4369           $caption = _clean($item);
4370           $i++;
4371         }
4372         if ($item =~ m/^P/) {
4373           $photogr = _clean($item);
4374           $i++;
4375         }
4376         if ($item =~ m/^i/) {
4377           $headln = _clean($item);
4378           $i++;
4379         }
4380         if ($item =~ m/^n/) {
4381           $credit = _clean($item);
4382           $i++;
4383         }
4384       }
4385     }
4386   }
4387   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
4388 }
4389
4390 sub Inline {
4391   # Inline added a new argument at the beginning
4392   my $lang = $_[-1];
4393
4394   $lang eq 'C'
4395     or die "Only C language supported";
4396
4397   require Imager::ExtUtils;
4398   return Imager::ExtUtils->inline_config;
4399 }
4400
4401 # threads shouldn't try to close raw Imager objects
4402 sub Imager::ImgRaw::CLONE_SKIP { 1 }
4403
4404 sub preload {
4405   # this serves two purposes:
4406   # - a class method to load the file support modules included with Imager
4407   #   (or were included, once the library dependent modules are split out)
4408   # - something for Module::ScanDeps to analyze
4409   # https://rt.cpan.org/Ticket/Display.html?id=6566
4410   local $@;
4411   local @INC = @INC;
4412   pop @INC if $INC[-1] eq '.';
4413   eval { require Imager::File::GIF };
4414   eval { require Imager::File::JPEG };
4415   eval { require Imager::File::PNG };
4416   eval { require Imager::File::SGI };
4417   eval { require Imager::File::TIFF };
4418   eval { require Imager::File::ICO };
4419   eval { require Imager::Font::W32 };
4420   eval { require Imager::Font::FT2 };
4421   eval { require Imager::Font::T1 };
4422   eval { require Imager::Color::Table };
4423
4424   1;
4425 }
4426
4427 package Imager::IO;
4428 use IO::Seekable;
4429
4430 sub new_fh {
4431   my ($class, $fh) = @_;
4432
4433   if (tied(*$fh)) {
4434     return $class->new_cb
4435       (
4436        sub {
4437          local $\;
4438
4439          return print $fh $_[0];
4440        },
4441        sub {
4442          my $tmp;
4443          my $count = CORE::read $fh, $tmp, $_[1];
4444          defined $count
4445            or return undef;
4446          $count
4447            or return "";
4448          return $tmp;
4449        },
4450        sub {
4451          if ($_[1] != SEEK_CUR || $_[0] != 0) {
4452            unless (CORE::seek $fh, $_[0], $_[1]) {
4453              return -1;
4454            }
4455          }
4456
4457          return tell $fh;
4458        },
4459        undef,
4460       );
4461   }
4462   else {
4463     return $class->_new_perlio($fh);
4464   }
4465 }
4466
4467 # backward compatibility for %formats
4468 package Imager::FORMATS;
4469 use strict;
4470 use constant IX_FORMATS => 0;
4471 use constant IX_LIST => 1;
4472 use constant IX_INDEX => 2;
4473 use constant IX_CLASSES => 3;
4474
4475 sub TIEHASH {
4476   my ($class, $formats, $classes) = @_;
4477
4478   return bless [ $formats, [ ], 0, $classes ], $class;
4479 }
4480
4481 sub _check {
4482   my ($self, $key) = @_;
4483
4484   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4485   my $value;
4486   my $error;
4487   my $loaded = Imager::_load_file($file, \$error);
4488   if ($loaded) {
4489     $value = 1;
4490   }
4491   else {
4492     if ($error =~ /^Can't locate /) {
4493       $error = "Can't locate $file";
4494     }
4495     $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
4496     $value = undef;
4497   }
4498   $self->[IX_FORMATS]{$key} = $value;
4499
4500   return $value;
4501 }
4502
4503 sub FETCH {
4504   my ($self, $key) = @_;
4505
4506   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4507
4508   $self->[IX_CLASSES]{$key} or return undef;
4509
4510   return $self->_check($key);
4511 }
4512
4513 sub STORE {
4514   die "%Imager::formats is not user monifiable";
4515 }
4516
4517 sub DELETE {
4518   die "%Imager::formats is not user monifiable";
4519 }
4520
4521 sub CLEAR {
4522   die "%Imager::formats is not user monifiable";
4523 }
4524
4525 sub EXISTS {
4526   my ($self, $key) = @_;
4527
4528   if (exists $self->[IX_FORMATS]{$key}) {
4529     my $value = $self->[IX_FORMATS]{$key}
4530       or return;
4531     return 1;
4532   }
4533
4534   $self->_check($key) or return 1==0;
4535
4536   return 1==1;
4537 }
4538
4539 sub FIRSTKEY {
4540   my ($self) = @_;
4541
4542   unless (@{$self->[IX_LIST]}) {
4543     # full populate it
4544     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4545       keys %{$self->[IX_FORMATS]};
4546
4547     for my $key (keys %{$self->[IX_CLASSES]}) {
4548       $self->[IX_FORMATS]{$key} and next;
4549       $self->_check($key)
4550         and push @{$self->[IX_LIST]}, $key;
4551     }
4552   }
4553
4554   @{$self->[IX_LIST]} or return;
4555   $self->[IX_INDEX] = 1;
4556   return $self->[IX_LIST][0];
4557 }
4558
4559 sub NEXTKEY {
4560   my ($self) = @_;
4561
4562   $self->[IX_INDEX] < @{$self->[IX_LIST]}
4563     or return;
4564
4565   return $self->[IX_LIST][$self->[IX_INDEX]++];
4566 }
4567
4568 sub SCALAR {
4569   my ($self) = @_;
4570
4571   return scalar @{$self->[IX_LIST]};
4572 }
4573
4574 1;
4575 __END__
4576 # Below is the stub of documentation for your module. You better edit it!
4577
4578 =head1 NAME
4579
4580 Imager - Perl extension for Generating 24 bit Images
4581
4582 =head1 SYNOPSIS
4583
4584   # Thumbnail example
4585
4586   #!/usr/bin/perl -w
4587   use strict;
4588   use Imager;
4589
4590   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
4591   my $file = shift;
4592
4593   my $format;
4594
4595   # see Imager::Files for information on the read() method
4596   my $img = Imager->new(file=>$file)
4597     or die Imager->errstr();
4598
4599   $file =~ s/\.[^.]*$//;
4600
4601   # Create smaller version
4602   # documented in Imager::Transformations
4603   my $thumb = $img->scale(scalefactor=>.3);
4604
4605   # Autostretch individual channels
4606   $thumb->filter(type=>'autolevels');
4607
4608   # try to save in one of these formats
4609   SAVE:
4610
4611   for $format ( qw( png gif jpeg tiff ppm ) ) {
4612     # Check if given format is supported
4613     if ($Imager::formats{$format}) {
4614       $file.="_low.$format";
4615       print "Storing image as: $file\n";
4616       # documented in Imager::Files
4617       $thumb->write(file=>$file) or
4618         die $thumb->errstr;
4619       last SAVE;
4620     }
4621   }
4622
4623 =head1 DESCRIPTION
4624
4625 Imager is a module for creating and altering images.  It can read and
4626 write various image formats, draw primitive shapes like lines,and
4627 polygons, blend multiple images together in various ways, scale, crop,
4628 render text and more.
4629
4630 =head2 Overview of documentation
4631
4632 =over
4633
4634 =item *
4635
4636 Imager - This document - Synopsis, Example, Table of Contents and
4637 Overview.
4638
4639 =item *
4640
4641 L<Imager::Install> - installation notes for Imager.
4642
4643 =item *
4644
4645 L<Imager::Tutorial> - a brief introduction to Imager.
4646
4647 =item *
4648
4649 L<Imager::Cookbook> - how to do various things with Imager.
4650
4651 =item *
4652
4653 L<Imager::ImageTypes> - Basics of constructing image objects with
4654 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4655 8/16/double bits/channel, color maps, channel masks, image tags, color
4656 quantization.  Also discusses basic image information methods.
4657
4658 =item *
4659
4660 L<Imager::Files> - IO interaction, reading/writing images, format
4661 specific tags.
4662
4663 =item *
4664
4665 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4666 flood fill.
4667
4668 =item *
4669
4670 L<Imager::Color> - Color specification.
4671
4672 =item *
4673
4674 L<Imager::Fill> - Fill pattern specification.
4675
4676 =item *
4677
4678 L<Imager::Font> - General font rendering, bounding boxes and font
4679 metrics.
4680
4681 =item *
4682
4683 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4684 blending, pasting, convert and map.
4685
4686 =item *
4687
4688 L<Imager::Engines> - Programmable transformations through
4689 C<transform()>, C<transform2()> and C<matrix_transform()>.
4690
4691 =item *
4692
4693 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4694 filter plug-ins.
4695
4696 =item *
4697
4698 L<Imager::Expr> - Expressions for evaluation engine used by
4699 transform2().
4700
4701 =item *
4702
4703 L<Imager::Matrix2d> - Helper class for affine transformations.
4704
4705 =item *
4706
4707 L<Imager::Fountain> - Helper for making gradient profiles.
4708
4709 =item *
4710
4711 L<Imager::IO> - Imager I/O abstraction.
4712
4713 =item *
4714
4715 L<Imager::API> - using Imager's C API
4716
4717 =item *
4718
4719 L<Imager::APIRef> - API function reference
4720
4721 =item *
4722
4723 L<Imager::Inline> - using Imager's C API from Inline::C
4724
4725 =item *
4726
4727 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4728
4729 =item *
4730
4731 L<Imager::Security> - brief security notes.
4732
4733 =item *
4734
4735 L<Imager::Threads> - brief information on working with threads.
4736
4737 =back
4738
4739 =head2 Basic Overview
4740
4741 An Image object is created with C<$img = Imager-E<gt>new()>.
4742 Examples:
4743
4744   $img=Imager->new();                         # create empty image
4745   $img->read(file=>'lena.png',type=>'png') or # read image from file
4746      die $img->errstr();                      # give an explanation
4747                                               # if something failed
4748
4749 or if you want to create an empty image:
4750
4751   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4752
4753 This example creates a completely black image of width 400 and height
4754 300 and 4 channels.
4755
4756 =head1 ERROR HANDLING
4757
4758 In general a method will return false when it fails, if it does use
4759 the C<errstr()> method to find out why:
4760
4761 =over
4762
4763 =item errstr()
4764
4765 Returns the last error message in that context.
4766
4767 If the last error you received was from calling an object method, such
4768 as read, call errstr() as an object method to find out why:
4769
4770   my $image = Imager->new;
4771   $image->read(file => 'somefile.gif')
4772      or die $image->errstr;
4773
4774 If it was a class method then call errstr() as a class method:
4775
4776   my @imgs = Imager->read_multi(file => 'somefile.gif')
4777     or die Imager->errstr;
4778
4779 Note that in some cases object methods are implemented in terms of
4780 class methods so a failing object method may set both.
4781
4782 =back
4783
4784 The C<Imager-E<gt>new> method is described in detail in
4785 L<Imager::ImageTypes>.
4786
4787 =head1 METHOD INDEX
4788
4789 Where to find information on methods for Imager class objects.
4790
4791 addcolors() - L<Imager::ImageTypes/addcolors()> - add colors to a
4792 paletted image
4793
4794 add_file_magic() - L<Imager::Files/add_file_magic()> - add magic to
4795 Imager's file type detector.
4796
4797 addtag() -  L<Imager::ImageTypes/addtag()> - add image tags
4798
4799 add_type_extensions() - L<Imager::Files/add_file_magic()> - add magic
4800 for new image file types.
4801
4802 L<Imager::Files/add_type_extensions($type, $ext, ...)> - add extensions for
4803 new image file types.
4804
4805 align_string() - L<Imager::Draw/align_string()> - draw text aligned on a
4806 point
4807
4808 alphachannel() - L<Imager::ImageTypes/alphachannel()> - return the
4809 channel index of the alpha channel (if any).
4810
4811 arc() - L<Imager::Draw/arc()> - draw a filled arc
4812
4813 bits() - L<Imager::ImageTypes/bits()> - number of bits per sample for the
4814 image
4815
4816 box() - L<Imager::Draw/box()> - draw a filled or outline box.
4817
4818 check_file_limits() - L<Imager::Files/check_file_limits()>
4819
4820 circle() - L<Imager::Draw/circle()> - draw a filled circle
4821
4822 close_log() - L<Imager::ImageTypes/close_log()> - close the Imager
4823 debugging log.
4824
4825 colorchannels() - L<Imager::ImageTypes/colorchannels()> - the number
4826 of channels used for color.
4827
4828 colorcount() - L<Imager::ImageTypes/colorcount()> - the number of
4829 colors in an image's palette (paletted images only)
4830
4831 colormodel() - L<Imager::ImageTypes/colorcount()> - how color is
4832 represented.
4833
4834 combine() - L<Imager::Transformations/combine()> - combine channels
4835 from one or more images.
4836
4837 combines() - L<Imager::Draw/combines()> - return a list of the
4838 different combine type keywords
4839
4840 compose() - L<Imager::Transformations/compose()> - compose one image
4841 over another.
4842
4843 convert() - L<Imager::Transformations/convert()> - transform the color
4844 space
4845
4846 copy() - L<Imager::Transformations/copy()> - make a duplicate of an
4847 image
4848
4849 crop() - L<Imager::Transformations/crop()> - extract part of an image
4850
4851 def_guess_type() - L<Imager::Files/def_guess_type()> - default function
4852 used to guess the output file format based on the output file name
4853
4854 deltag() -  L<Imager::ImageTypes/deltag()> - delete image tags
4855
4856 difference() - L<Imager::Filters/difference()> - produce a difference
4857 images from two input images.
4858
4859 errstr() - L</errstr()> - the error from the last failed operation.
4860
4861 filter() - L<Imager::Filters/filter()> - image filtering
4862
4863 findcolor() - L<Imager::ImageTypes/findcolor()> - search the image
4864 palette, if it has one
4865
4866 flip() - L<Imager::Transformations/flip()> - flip an image, vertically,
4867 horizontally
4868
4869 flood_fill() - L<Imager::Draw/flood_fill()> - fill an enclosed or same
4870 color area
4871
4872 getchannels() - L<Imager::ImageTypes/getchannels()> - the number of
4873 samples per pixel for an image
4874
4875 getcolorcount() - L<Imager::ImageTypes/getcolorcount()> - the number of
4876 different colors used by an image (works for direct color images)
4877
4878 getcolors() - L<Imager::ImageTypes/getcolors()> - get colors from the image
4879 palette, if it has one
4880
4881 getcolorusage() - L<Imager::ImageTypes/getcolorusage()>
4882
4883 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash()>
4884
4885 get_file_limits() - L<Imager::Files/get_file_limits()>
4886
4887 getheight() - L<Imager::ImageTypes/getheight()> - height of the image in
4888 pixels
4889
4890 getmask() - L<Imager::ImageTypes/getmask()> - write mask for the image
4891
4892 getpixel() - L<Imager::Draw/getpixel()> - retrieve one or more pixel
4893 colors
4894
4895 getsamples() - L<Imager::Draw/getsamples()> - retrieve samples from a
4896 row or partial row of pixels.
4897
4898 getscanline() - L<Imager::Draw/getscanline()> - retrieve colors for a
4899 row or partial row of pixels.
4900
4901 getwidth() - L<Imager::ImageTypes/getwidth()> - width of the image in
4902 pixels.
4903
4904 img_set() - L<Imager::ImageTypes/img_set()> - re-use an Imager object
4905 for a new image.
4906
4907 init() - L<Imager::ImageTypes/init()>
4908
4909 is_bilevel() - L<Imager::ImageTypes/is_bilevel()> - returns whether
4910 image write functions should write the image in their bilevel (blank
4911 and white, no gray levels) format
4912
4913 is_logging() L<Imager::ImageTypes/is_logging()> - test if the debug
4914 log is active.
4915
4916 line() - L<Imager::Draw/line()> - draw an interval
4917
4918 load_plugin() - L<Imager::Filters/load_plugin()>
4919
4920 log() - L<Imager::ImageTypes/log()> - send a message to the debugging
4921 log.
4922
4923 make_palette() - L<Imager::ImageTypes/make_palette()> - produce a
4924 color palette from one or more input images.
4925
4926 map() - L<Imager::Transformations/map()> - remap color
4927 channel values
4928
4929 masked() -  L<Imager::ImageTypes/masked()> - make a masked image
4930
4931 matrix_transform() - L<Imager::Engines/matrix_transform()>
4932
4933 maxcolors() - L<Imager::ImageTypes/maxcolors()>
4934
4935 NC() - L<Imager::Handy/NC()>
4936
4937 NCF() - L<Imager::Handy/NCF()>
4938
4939 new() - L<Imager::ImageTypes/new()>
4940
4941 newcolor() - L<Imager::Handy/newcolor()>
4942
4943 newcolour() - L<Imager::Handy/newcolour()>
4944
4945 newfont() - L<Imager::Handy/newfont()>
4946
4947 NF() - L<Imager::Handy/NF()>
4948
4949 open() - L<Imager::Files/read()> - an alias for read()
4950
4951 open_log() - L<Imager::ImageTypes/open_log()> - open the debug log.
4952
4953 =for stopwords IPTC
4954
4955 parseiptc() - L<Imager::Files/parseiptc()> - parse IPTC data from a JPEG
4956 image
4957
4958 paste() - L<Imager::Transformations/paste()> - draw an image onto an
4959 image
4960
4961 polygon() - L<Imager::Draw/polygon()>
4962
4963 polyline() - L<Imager::Draw/polyline()>
4964
4965 polypolygon() - L<Imager::Draw/polypolygon()>
4966
4967 preload() - L<Imager::Files/preload()>
4968
4969 read() - L<Imager::Files/read()> - read a single image from an image file
4970
4971 read_multi() - L<Imager::Files/read_multi()> - read multiple images from an image
4972 file
4973
4974 read_types() - L<Imager::Files/read_types()> - list image types Imager
4975 can read.
4976
4977 register_filter() - L<Imager::Filters/register_filter()>
4978
4979 register_reader() - L<Imager::Files/register_reader()>
4980
4981 register_writer() - L<Imager::Files/register_writer()>
4982
4983 rotate() - L<Imager::Transformations/rotate()>
4984
4985 rubthrough() - L<Imager::Transformations/rubthrough()> - draw an image
4986 onto an image and use the alpha channel
4987
4988 scale() - L<Imager::Transformations/scale()>
4989
4990 scale_calculate() - L<Imager::Transformations/scale_calculate()>
4991
4992 scaleX() - L<Imager::Transformations/scaleX()>
4993
4994 scaleY() - L<Imager::Transformations/scaleY()>
4995
4996 setcolors() - L<Imager::ImageTypes/setcolors()> - set palette colors
4997 in a paletted image
4998
4999 set_file_limits() - L<Imager::Files/set_file_limits()>
5000
5001 setmask() - L<Imager::ImageTypes/setmask()>
5002
5003 setpixel() - L<Imager::Draw/setpixel()>
5004
5005 setsamples() - L<Imager::Draw/setsamples()>
5006
5007 setscanline() - L<Imager::Draw/setscanline()>
5008
5009 settag() - L<Imager::ImageTypes/settag()>
5010
5011 string() - L<Imager::Draw/string()> - draw text on an image
5012
5013 tags() -  L<Imager::ImageTypes/tags()> - fetch image tags
5014
5015 to_paletted() -  L<Imager::ImageTypes/to_paletted()>
5016
5017 to_rgb16() - L<Imager::ImageTypes/to_rgb16()>
5018
5019 to_rgb8() - L<Imager::ImageTypes/to_rgb8()>
5020
5021 to_rgb_double() - L<Imager::ImageTypes/to_rgb_double()> - convert to
5022 double per sample image.
5023
5024 transform() - L<Imager::Engines/"transform()">
5025
5026 transform2() - L<Imager::Engines/"transform2()">
5027
5028 type() -  L<Imager::ImageTypes/type()> - type of image (direct vs paletted)
5029
5030 unload_plugin() - L<Imager::Filters/unload_plugin()>
5031
5032 virtual() - L<Imager::ImageTypes/virtual()> - whether the image has it's own
5033 data
5034
5035 write() - L<Imager::Files/write()> - write an image to a file
5036
5037 write_multi() - L<Imager::Files/write_multi()> - write multiple image to an image
5038 file.
5039
5040 write_types() - L<Imager::Files/read_types()> - list image types Imager
5041 can write.
5042
5043 =head1 CONCEPT INDEX
5044
5045 animated GIF - L<Imager::Files/"Writing an animated GIF">
5046
5047 aspect ratio - C<i_xres>, C<i_yres>, C<i_aspect_only> in
5048 L<Imager::ImageTypes/"Common Tags">.
5049
5050 blend - alpha blending one image onto another
5051 L<Imager::Transformations/rubthrough()>
5052
5053 blur - L<< Imager::Filters/C<gaussian> >>, L<< Imager::Filters/C<conv> >>
5054
5055 boxes, drawing - L<Imager::Draw/box()>
5056
5057 changes between image - L<Imager::Filters/"Image Difference">
5058
5059 channels, combine into one image - L<Imager::Transformations/combine()>
5060
5061 color - L<Imager::Color>
5062
5063 color names - L<Imager::Color>, L<Imager::Color::Table>
5064
5065 combine modes - L<Imager::Draw/"Combine Types">
5066
5067 compare images - L<Imager::Filters/"Image Difference">
5068
5069 contrast - L<< Imager::Filters/C<contrast> >>, L<< Imager::Filters/C<autolevels> >>
5070
5071 convolution - L<< Imager::Filters/C<conv> >>
5072
5073 cropping - L<Imager::Transformations/crop()>
5074
5075 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
5076
5077 C<diff> images - L<Imager::Filters/"Image Difference">
5078
5079 dpi - C<i_xres>, C<i_yres> in L<Imager::ImageTypes/"Common Tags">,
5080 L<Imager::Cookbook/"Image spatial resolution">
5081
5082 drawing boxes - L<Imager::Draw/box()>
5083
5084 drawing lines - L<Imager::Draw/line()>
5085
5086 drawing text - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>
5087
5088 error message - L</"ERROR HANDLING">
5089
5090 files, font - L<Imager::Font>
5091
5092 files, image - L<Imager::Files>
5093
5094 filling, types of fill - L<Imager::Fill>
5095
5096 filling, boxes - L<Imager::Draw/box()>
5097
5098 filling, flood fill - L<Imager::Draw/flood_fill()>
5099
5100 flood fill - L<Imager::Draw/flood_fill()>
5101
5102 fonts - L<Imager::Font>
5103
5104 fonts, drawing with - L<Imager::Draw/string()>,
5105 L<Imager::Draw/align_string()>, L<Imager::Font::Wrap>
5106
5107 fonts, metrics - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
5108
5109 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
5110
5111 fountain fill - L<Imager::Fill/"Fountain fills">,
5112 L<< Imager::Filters/C<fountain> >>, L<Imager::Fountain>,
5113 L<< Imager::Filters/C<gradgen> >>
5114
5115 GIF files - L<Imager::Files/"GIF">
5116
5117 GIF files, animated - L<Imager::Files/"Writing an animated GIF">
5118
5119 gradient fill - L<Imager::Fill/"Fountain fills">,
5120 L<< Imager::Filters/C<fountain> >>, L<Imager::Fountain>,
5121 L<< Imager::Filters/C<gradgen> >>
5122
5123 gray scale, convert image to - L<Imager::Transformations/convert()>
5124
5125 gaussian blur - L<< Imager::Filters/C<gaussian> >>, L<< Imager::Filters/C<gaussian2> >>
5126
5127 hatch fills - L<Imager::Fill/"Hatched fills">
5128
5129 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
5130
5131 invert image - L<< Imager::Filters/C<hardinvert> >>,
5132 L<< Imager::Filters/C<hardinvertall> >>
5133
5134 JPEG - L<Imager::Files/"JPEG">
5135
5136 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
5137
5138 lines, drawing - L<Imager::Draw/line()>
5139
5140 matrix - L<Imager::Matrix2d>, 
5141 L<Imager::Engines/"Matrix Transformations">,
5142 L<Imager::Font/transform()>
5143
5144 metadata, image - L<Imager::ImageTypes/"Tags">, L<Image::ExifTool>
5145
5146 mosaic - L<< Imager::Filters/C<mosaic> >>
5147
5148 noise, filter - L<< Imager::Filters/C<noise> >>
5149
5150 noise, rendered - L<< Imager::Filters/C<turbnoise> >>,
5151 L<< Imager::Filters/C<radnoise> >>
5152
5153 paste - L<Imager::Transformations/paste()>,
5154 L<Imager::Transformations/rubthrough()>
5155
5156 pseudo-color image - L<Imager::ImageTypes/to_paletted()>,
5157 L<Imager::ImageTypes/new()>
5158
5159 =for stopwords posterize
5160
5161 posterize - L<< Imager::Filters/C<postlevels> >>
5162
5163 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
5164
5165 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
5166
5167 rectangles, drawing - L<Imager::Draw/box()>
5168
5169 resizing an image - L<Imager::Transformations/scale()>, 
5170 L<Imager::Transformations/crop()>
5171
5172 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
5173
5174 saving an image - L<Imager::Files>
5175
5176 scaling - L<Imager::Transformations/scale()>
5177
5178 security - L<Imager::Security>
5179
5180 SGI files - L<Imager::Files/"SGI (RGB, BW)">
5181
5182 sharpen - L<< Imager::Filters/C<unsharpmask> >>, L<< Imager::Filters/C<conv> >>
5183
5184 size, image - L<Imager::ImageTypes/getwidth()>,
5185 L<Imager::ImageTypes/getheight()>
5186
5187 size, text - L<Imager::Font/bounding_box()>
5188
5189 tags, image metadata - L<Imager::ImageTypes/"Tags">
5190
5191 text, drawing - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>,
5192 L<Imager::Font::Wrap>
5193
5194 text, wrapping text in an area - L<Imager::Font::Wrap>
5195
5196 text, measuring - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
5197
5198 threads - L<Imager::Threads>
5199
5200 tiles, color - L<< Imager::Filters/C<mosaic> >>
5201
5202 transparent images - L<Imager::ImageTypes>,
5203 L<Imager::Cookbook/"Transparent PNG">
5204
5205 =for stopwords unsharp
5206
5207 unsharp mask - L<< Imager::Filters/C<unsharpmask> >>
5208
5209 watermark - L<< Imager::Filters/C<watermark> >>
5210
5211 writing an image to a file - L<Imager::Files>
5212
5213 =head1 SUPPORT
5214
5215 The best place to get help with Imager is the mailing list.
5216
5217 To subscribe send a message with C<subscribe> in the body to:
5218
5219    imager-devel+request@molar.is
5220
5221 or use the form at:
5222
5223 =over
5224
5225 L<http://www.molar.is/en/lists/imager-devel/>
5226
5227 =back
5228
5229 where you can also find the mailing list archive.
5230
5231 You can report bugs either via github at:
5232
5233 =over
5234
5235 L<https://github.com/tonycoz/imager/issues>
5236
5237 =back
5238
5239 or at:
5240
5241 =over
5242
5243 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
5244
5245 =back
5246
5247 or by sending an email to:
5248
5249 =over
5250
5251 bug-Imager@rt.cpan.org
5252
5253 =back
5254
5255 Please remember to include the versions of Imager, perl, supporting
5256 libraries, and any relevant code.  If you have specific images that
5257 cause the problems, please include those too.
5258
5259 =head1 CONTRIBUTING TO IMAGER
5260
5261 =head2 Feedback
5262
5263 I like feedback.
5264
5265 You can send email to the maintainer below.
5266
5267 If you send me a bug report via email, it will be copied to Request
5268 Tracker.
5269
5270 =head2 Patches
5271
5272 I accept patches, preferably against the master branch in git.  Please
5273 include an explanation of the reason for why the patch is needed or
5274 useful.
5275
5276 Your patch should include regression tests where possible, otherwise
5277 it will be delayed until I get a chance to write them.
5278
5279 To browse Imager's git repository:
5280
5281   https://github.com/tonycoz/imager.git
5282
5283 To clone:
5284
5285   git clone git://github.com/tonycoz/imager.git
5286
5287 Or you can create a fork as usual on github and submit a github pull
5288 request.
5289
5290 Patches can either be submitted as a github pull request or by using
5291 C<git format-patch>, for example, if you made your changes in a branch
5292 from master you might do:
5293
5294   git format-patch -k --stdout master >my-patch.txt
5295
5296 and then attach that to your bug report, either by adding it as an