Imager.pm

   1 package Imager;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS $warn_obsolete);
   5 use IO::File;
   6
   7 use Imager::Color;
   8 use Imager::Font;
   9
  10 @EXPORT_OK = qw(
  11                 init
  12                 init_log
  13                 DSO_open
  14                 DSO_close
  15                 DSO_funclist
  16                 DSO_call
  17
  18                 load_plugin
  19                 unload_plugin
  20
  21                 i_list_formats
  22                 i_has_format
  23
  24                 i_color_new
  25                 i_color_set
  26                 i_color_info
  27
  28                 i_img_empty
  29                 i_img_empty_ch
  30                 i_img_exorcise
  31                 i_img_destroy
  32
  33                 i_img_info
  34
  35                 i_img_setmask
  36                 i_img_getmask
  37
  38                 i_line
  39                 i_line_aa
  40                 i_box
  41                 i_box_filled
  42                 i_arc
  43                 i_circle_aa
  44
  45                 i_bezier_multi
  46                 i_poly_aa
  47                 i_poly_aa_cfill
  48
  49                 i_copyto
  50                 i_rubthru
  51                 i_scaleaxis
  52                 i_scale_nn
  53                 i_haar
  54                 i_count_colors
  55
  56                 i_gaussian
  57                 i_conv
  58
  59                 i_convert
  60                 i_map
  61
  62                 i_img_diff
  63
  64                 i_init_fonts
  65                 i_t1_new
  66                 i_t1_destroy
  67                 i_t1_set_aa
  68                 i_t1_cp
  69                 i_t1_text
  70                 i_t1_bbox
  71
  72                 i_tt_set_aa
  73                 i_tt_cp
  74                 i_tt_text
  75                 i_tt_bbox
  76
  77                 i_readjpeg_wiol
  78                 i_writejpeg_wiol
  79
  80                 i_readtiff_wiol
  81                 i_writetiff_wiol
  82                 i_writetiff_wiol_faxable
  83
  84                 i_readpng_wiol
  85                 i_writepng_wiol
  86
  87                 i_readgif
  88                 i_readgif_wiol
  89                 i_readgif_callback
  90                 i_writegif
  91                 i_writegifmc
  92                 i_writegif_gen
  93                 i_writegif_callback
  94
  95                 i_readpnm_wiol
  96                 i_writeppm_wiol
  97
  98                 i_readraw_wiol
  99                 i_writeraw_wiol
 100
 101                 i_contrast
 102                 i_hardinvert
 103                 i_noise
 104                 i_bumpmap
 105                 i_postlevels
 106                 i_mosaic
 107                 i_watermark
 108
 109                 malloc_state
 110
 111                 list_formats
 112
 113                 i_gifquant
 114
 115                 newfont
 116                 newcolor
 117                 newcolour
 118                 NC
 119                 NF
 120 );
 121
 122 @EXPORT=qw(
 123            init_log
 124            i_list_formats
 125            i_has_format
 126            malloc_state
 127            i_color_new
 128
 129            i_img_empty
 130            i_img_empty_ch
 131           );
 132
 133 %EXPORT_TAGS=
 134   (handy => [qw(
 135                 newfont
 136                 newcolor
 137                 NF
 138                 NC
 139                )],
 140    all => [@EXPORT_OK],
 141    default => [qw(
 142                   load_plugin
 143                   unload_plugin
 144                  )]);
 145
 146 # registered file readers
 147 my %readers;
 148
 149 # registered file writers
 150 my %writers;
 151
 152 # modules we attempted to autoload
 153 my %attempted_to_load;
 154
 155 BEGIN {
 156   require Exporter;
 157   @ISA = qw(Exporter);
 158   $VERSION = '0.59';
 159   eval {
 160     require XSLoader;
 161     XSLoader::load(Imager => $VERSION);
 162     1;
 163   } or do {
 164     require DynaLoader;
 165     push @ISA, 'DynaLoader';
 166     bootstrap Imager $VERSION;
 167   }
 168 }
 169
 170 BEGIN {
 171   i_init_fonts(); # Initialize font engines
 172   Imager::Font::__init();
 173   for(i_list_formats()) { $formats{$_}++; }
 174
 175   if ($formats{'t1'}) {
 176     i_t1_set_aa(1);
 177   }
 178
 179   if (!$formats{'t1'} and !$formats{'tt'}
 180       && !$formats{'ft2'} && !$formats{'w32'}) {
 181     $fontstate='no font support';
 182   }
 183
 184   %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
 185
 186   $DEBUG=0;
 187
 188   # the members of the subhashes under %filters are:
 189   #  callseq - a list of the parameters to the underlying filter in the
 190   #            order they are passed
 191   #  callsub - a code ref that takes a named parameter list and calls the
 192   #            underlying filter
 193   #  defaults - a hash of default values
 194   #  names - defines names for value of given parameters so if the names
 195   #          field is foo=> { bar=>1 }, and the user supplies "bar" as the
 196   #          foo parameter, the filter will receive 1 for the foo
 197   #          parameter
 198   $filters{contrast}={
 199                       callseq => ['image','intensity'],
 200                       callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
 201                      };
 202
 203   $filters{noise} ={
 204                     callseq => ['image', 'amount', 'subtype'],
 205                     defaults => { amount=>3,subtype=>0 },
 206                     callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
 207                    };
 208
 209   $filters{hardinvert} ={
 210                          callseq => ['image'],
 211                          defaults => { },
 212                          callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
 213                         };
 214
 215   $filters{autolevels} ={
 216                          callseq => ['image','lsat','usat','skew'],
 217                          defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
 218                          callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
 219                         };
 220
 221   $filters{turbnoise} ={
 222                         callseq => ['image'],
 223                         defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
 224                         callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
 225                        };
 226
 227   $filters{radnoise} ={
 228                        callseq => ['image'],
 229                        defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
 230                        callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
 231                       };
 232
 233   $filters{conv} ={
 234                        callseq => ['image', 'coef'],
 235                        defaults => { },
 236                        callsub => sub { my %hsh=@_; i_conv($hsh{image},$hsh{coef}); }
 237                       };
 238
 239   $filters{gradgen} =
 240     {
 241      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 242      defaults => { dist => 0 },
 243      callsub =>
 244      sub {
 245        my %hsh=@_;
 246        my @colors = @{$hsh{colors}};
 247        $_ = _color($_)
 248          for @colors;
 249        i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
 250      }
 251     };
 252
 253   $filters{nearest_color} =
 254     {
 255      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 256      defaults => { },
 257      callsub =>
 258      sub {
 259        my %hsh=@_;
 260        # make sure the segments are specified with colors
 261        my @colors;
 262        for my $color (@{$hsh{colors}}) {
 263          my $new_color = _color($color)
 264            or die $Imager::ERRSTR."\n";
 265          push @colors, $new_color;
 266        }
 267
 268        i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors,
 269                        $hsh{dist})
 270          or die Imager->_error_as_msg() . "\n";
 271      },
 272     };
 273   $filters{gaussian} = {
 274                         callseq => [ 'image', 'stddev' ],
 275                         defaults => { },
 276                         callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
 277                        };
 278   $filters{mosaic} =
 279     {
 280      callseq => [ qw(image size) ],
 281      defaults => { size => 20 },
 282      callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
 283     };
 284   $filters{bumpmap} =
 285     {
 286      callseq => [ qw(image bump elevation lightx lighty st) ],
 287      defaults => { elevation=>0, st=> 2 },
 288      callsub => sub {
 289        my %hsh = @_;
 290        i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
 291                  $hsh{lightx}, $hsh{lighty}, $hsh{st});
 292      },
 293     };
 294   $filters{bumpmap_complex} =
 295     {
 296      callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
 297      defaults => {
 298                   channel => 0,
 299                   tx => 0,
 300                   ty => 0,
 301                   Lx => 0.2,
 302                   Ly => 0.4,
 303                   Lz => -1.0,
 304                   cd => 1.0,
 305                   cs => 40,
 306                   n => 1.3,
 307                   Ia => Imager::Color->new(rgb=>[0,0,0]),
 308                   Il => Imager::Color->new(rgb=>[255,255,255]),
 309                   Is => Imager::Color->new(rgb=>[255,255,255]),
 310                  },
 311      callsub => sub {
 312        my %hsh = @_;
 313        i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
 314                  $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
 315                  $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
 316                  $hsh{Is});
 317      },
 318     };
 319   $filters{postlevels} =
 320     {
 321      callseq  => [ qw(image levels) ],
 322      defaults => { levels => 10 },
 323      callsub  => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
 324     };
 325   $filters{watermark} =
 326     {
 327      callseq  => [ qw(image wmark tx ty pixdiff) ],
 328      defaults => { pixdiff=>10, tx=>0, ty=>0 },
 329      callsub  =>
 330      sub {
 331        my %hsh = @_;
 332        i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
 333                    $hsh{pixdiff});
 334      },
 335     };
 336   $filters{fountain} =
 337     {
 338      callseq  => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
 339      names    => {
 340                   ftype => { linear         => 0,
 341                              bilinear       => 1,
 342                              radial         => 2,
 343                              radial_square  => 3,
 344                              revolution     => 4,
 345                              conical        => 5 },
 346                   repeat => { none      => 0,
 347                               sawtooth  => 1,
 348                               triangle  => 2,
 349                               saw_both  => 3,
 350                               tri_both  => 4,
 351                             },
 352                   super_sample => {
 353                                    none    => 0,
 354                                    grid    => 1,
 355                                    random  => 2,
 356                                    circle  => 3,
 357                                   },
 358                   combine => {
 359                               none      => 0,
 360                               normal    => 1,
 361                               multiply  => 2, mult => 2,
 362                               dissolve  => 3,
 363                               add       => 4,
 364                               subtract  => 5, 'sub' => 5,
 365                               diff      => 6,
 366                               lighten   => 7,
 367                               darken    => 8,
 368                               hue       => 9,
 369                               sat       => 10,
 370                               value     => 11,
 371                               color     => 12,
 372                              },
 373                  },
 374      defaults => { ftype => 0, repeat => 0, combine => 0,
 375                    super_sample => 0, ssample_param => 4,
 376                    segments=>[
 377                               [ 0, 0.5, 1,
 378                                 Imager::Color->new(0,0,0),
 379                                 Imager::Color->new(255, 255, 255),
 380                                 0, 0,
 381                               ],
 382                              ],
 383                  },
 384      callsub  =>
 385      sub {
 386        my %hsh = @_;
 387
 388        # make sure the segments are specified with colors
 389        my @segments;
 390        for my $segment (@{$hsh{segments}}) {
 391          my @new_segment = @$segment;
 392
 393          $_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
 394          push @segments, \@new_segment;
 395        }
 396
 397        i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
 398                   $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
 399                   $hsh{ssample_param}, \@segments)
 400          or die Imager->_error_as_msg() . "\n";
 401      },
 402     };
 403   $filters{unsharpmask} =
 404     {
 405      callseq => [ qw(image stddev scale) ],
 406      defaults => { stddev=>2.0, scale=>1.0 },
 407      callsub =>
 408      sub {
 409        my %hsh = @_;
 410        i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
 411      },
 412     };
 413
 414   $FORMATGUESS=\&def_guess_type;
 415
 416   $warn_obsolete = 1;
 417 }
 418
 419 #
 420 # Non methods
 421 #
 422
 423 # initlize Imager
 424 # NOTE: this might be moved to an import override later on
 425
 426 #sub import {
 427 #  my $pack = shift;
 428 #  (look through @_ for special tags, process, and remove them);
 429 #  use Data::Dumper;
 430 #  print Dumper($pack);
 431 #  print Dumper(@_);
 432 #}
 433
 434 sub init_log {
 435   i_init_log($_[0],$_[1]);
 436   i_log_entry("Imager $VERSION starting\n", 1);
 437 }
 438
 439
 440 sub init {
 441   my %parms=(loglevel=>1,@_);
 442   if ($parms{'log'}) {
 443     init_log($parms{'log'},$parms{'loglevel'});
 444   }
 445
 446   if (exists $parms{'warn_obsolete'}) {
 447     $warn_obsolete = $parms{'warn_obsolete'};
 448   }
 449
 450 #    if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
 451 #    if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
 452 #       i_init_fonts();
 453 #       $fontstate='ok';
 454 #    }
 455   if (exists $parms{'t1log'}) {
 456     i_init_fonts($parms{'t1log'});
 457   }
 458 }
 459
 460 END {
 461   if ($DEBUG) {
 462     print "shutdown code\n";
 463     #   for(keys %instances) { $instances{$_}->DESTROY(); }
 464     malloc_state(); # how do decide if this should be used? -- store something from the import
 465     print "Imager exiting\n";
 466   }
 467 }
 468
 469 # Load a filter plugin
 470
 471 sub load_plugin {
 472   my ($filename)=@_;
 473   my $i;
 474   my ($DSO_handle,$str)=DSO_open($filename);
 475   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
 476   my %funcs=DSO_funclist($DSO_handle);
 477   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
 478   $i=0;
 479   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
 480
 481   $DSOs{$filename}=[$DSO_handle,\%funcs];
 482
 483   for(keys %funcs) {
 484     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
 485     $DEBUG && print "eval string:\n",$evstr,"\n";
 486     eval $evstr;
 487     print $@ if $@;
 488   }
 489   return 1;
 490 }
 491
 492 # Unload a plugin
 493
 494 sub unload_plugin {
 495   my ($filename)=@_;
 496
 497   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
 498   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
 499   for(keys %{$funcref}) {
 500     delete $filters{$_};
 501     $DEBUG && print "unloading: $_\n";
 502   }
 503   my $rc=DSO_close($DSO_handle);
 504   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
 505   return 1;
 506 }
 507
 508 # take the results of i_error() and make a message out of it
 509 sub _error_as_msg {
 510   return join(": ", map $_->[0], i_errors());
 511 }
 512
 513 # this function tries to DWIM for color parameters
 514 #  color objects are used as is
 515 #  simple scalars are simply treated as single parameters to Imager::Color->new
 516 #  hashrefs are treated as named argument lists to Imager::Color->new
 517 #  arrayrefs are treated as list arguments to Imager::Color->new iff any
 518 #    parameter is > 1
 519 #  other arrayrefs are treated as list arguments to Imager::Color::Float
 520
 521 sub _color {
 522   my $arg = shift;
 523   # perl 5.6.0 seems to do weird things to $arg if we don't make an
 524   # explicitly stringified copy
 525   # I vaguely remember a bug on this on p5p, but couldn't find it
 526   # through bugs.perl.org (I had trouble getting it to find any bugs)
 527   my $copy = $arg . "";
 528   my $result;
 529
 530   if (ref $arg) {
 531     if (UNIVERSAL::isa($arg, "Imager::Color")
 532         || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
 533       $result = $arg;
 534     }
 535     else {
 536       if ($copy =~ /^HASH\(/) {
 537         $result = Imager::Color->new(%$arg);
 538       }
 539       elsif ($copy =~ /^ARRAY\(/) {
 540         $result = Imager::Color->new(@$arg);
 541       }
 542       else {
 543         $Imager::ERRSTR = "Not a color";
 544       }
 545     }
 546   }
 547   else {
 548     # assume Imager::Color::new knows how to handle it
 549     $result = Imager::Color->new($arg);
 550   }
 551
 552   return $result;
 553 }
 554
 555 sub _valid_image {
 556   my ($self) = @_;
 557
 558   $self->{IMG} and return 1;
 559
 560   $self->_set_error('empty input image');
 561
 562   return;
 563 }
 564
 565 #
 566 # Methods to be called on objects.
 567 #
 568
 569 # Create a new Imager object takes very few parameters.
 570 # usually you call this method and then call open from
 571 # the resulting object
 572
 573 sub new {
 574   my $class = shift;
 575   my $self ={};
 576   my %hsh=@_;
 577   bless $self,$class;
 578   $self->{IMG}=undef;    # Just to indicate what exists
 579   $self->{ERRSTR}=undef; #
 580   $self->{DEBUG}=$DEBUG;
 581   $self->{DEBUG} && print "Initialized Imager\n";
 582   if (defined $hsh{xsize} && defined $hsh{ysize}) {
 583     unless ($self->img_set(%hsh)) {
 584       $Imager::ERRSTR = $self->{ERRSTR};
 585       return;
 586     }
 587   }
 588   return $self;
 589 }
 590
 591 # Copy an entire image with no changes
 592 # - if an image has magic the copy of it will not be magical
 593
 594 sub copy {
 595   my $self = shift;
 596   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 597
 598   unless (defined wantarray) {
 599     my @caller = caller;
 600     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
 601     return;
 602   }
 603
 604   my $newcopy=Imager->new();
 605   $newcopy->{IMG} = i_copy($self->{IMG});
 606   return $newcopy;
 607 }
 608
 609 # Paste a region
 610
 611 sub paste {
 612   my $self = shift;
 613
 614   unless ($self->{IMG}) {
 615     $self->_set_error('empty input image');
 616     return;
 617   }
 618   my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
 619   my $src = $input{img} || $input{src};
 620   unless($src) {
 621     $self->_set_error("no source image");
 622     return;
 623   }
 624   $input{left}=0 if $input{left} <= 0;
 625   $input{top}=0 if $input{top} <= 0;
 626
 627   my($r,$b)=i_img_info($src->{IMG});
 628   my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
 629   my ($src_right, $src_bottom);
 630   if ($input{src_coords}) {
 631     ($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
 632   }
 633   else {
 634     if (defined $input{src_maxx}) {
 635       $src_right = $input{src_maxx};
 636     }
 637     elsif (defined $input{width}) {
 638       if ($input{width} <= 0) {
 639         $self->_set_error("paste: width must me positive");
 640         return;
 641       }
 642       $src_right = $src_left + $input{width};
 643     }
 644     else {
 645       $src_right = $r;
 646     }
 647     if (defined $input{src_maxy}) {
 648       $src_bottom = $input{src_maxy};
 649     }
 650     elsif (defined $input{height}) {
 651       if ($input{height} < 0) {
 652         $self->_set_error("paste: height must be positive");
 653         return;
 654       }
 655       $src_bottom = $src_top + $input{height};
 656     }
 657     else {
 658       $src_bottom = $b;
 659     }
 660   }
 661
 662   $src_right > $r and $src_right = $r;
 663   $src_bottom > $b and $src_bottom = $b;
 664
 665   if ($src_right <= $src_left
 666       || $src_bottom < $src_top) {
 667     $self->_set_error("nothing to paste");
 668     return;
 669   }
 670
 671   i_copyto($self->{IMG}, $src->{IMG},
 672            $src_left, $src_top, $src_right, $src_bottom,
 673            $input{left}, $input{top});
 674
 675   return $self;  # What should go here??
 676 }
 677
 678 # Crop an image - i.e. return a new image that is smaller
 679
 680 sub crop {
 681   my $self=shift;
 682   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 683
 684   unless (defined wantarray) {
 685     my @caller = caller;
 686     warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
 687     return;
 688   }
 689
 690   my %hsh=@_;
 691
 692   my ($w, $h, $l, $r, $b, $t) =
 693     @hsh{qw(width height left right bottom top)};
 694
 695   # work through the various possibilities
 696   if (defined $l) {
 697     if (defined $w) {
 698       $r = $l + $w;
 699     }
 700     elsif (!defined $r) {
 701       $r = $self->getwidth;
 702     }
 703   }
 704   elsif (defined $r) {
 705     if (defined $w) {
 706       $l = $r - $w;
 707     }
 708     else {
 709       $l = 0;
 710     }
 711   }
 712   elsif (defined $w) {
 713     $l = int(0.5+($self->getwidth()-$w)/2);
 714     $r = $l + $w;
 715   }
 716   else {
 717     $l = 0;
 718     $r = $self->getwidth;
 719   }
 720   if (defined $t) {
 721     if (defined $h) {
 722       $b = $t + $h;
 723     }
 724     elsif (!defined $b) {
 725       $b = $self->getheight;
 726     }
 727   }
 728   elsif (defined $b) {
 729     if (defined $h) {
 730       $t = $b - $h;
 731     }
 732     else {
 733       $t = 0;
 734     }
 735   }
 736   elsif (defined $h) {
 737     $t=int(0.5+($self->getheight()-$h)/2);
 738     $b=$t+$h;
 739   }
 740   else {
 741     $t = 0;
 742     $b = $self->getheight;
 743   }
 744
 745   ($l,$r)=($r,$l) if $l>$r;
 746   ($t,$b)=($b,$t) if $t>$b;
 747
 748   $l < 0 and $l = 0;
 749   $r > $self->getwidth and $r = $self->getwidth;
 750   $t < 0 and $t = 0;
 751   $b > $self->getheight and $b = $self->getheight;
 752
 753   if ($l == $r || $t == $b) {
 754     $self->_set_error("resulting image would have no content");
 755     return;
 756   }
 757   if( $r < $l or $b < $t ) {
 758     $self->_set_error("attempting to crop outside of the image");
 759     return;
 760   }
 761   my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
 762
 763   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
 764   return $dst;
 765 }
 766
 767 sub _sametype {
 768   my ($self, %opts) = @_;
 769
 770   $self->{IMG} or return $self->_set_error("Not a valid image");
 771
 772   my $x = $opts{xsize} || $self->getwidth;
 773   my $y = $opts{ysize} || $self->getheight;
 774   my $channels = $opts{channels} || $self->getchannels;
 775
 776   my $out = Imager->new;
 777   if ($channels == $self->getchannels) {
 778     $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
 779   }
 780   else {
 781     $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
 782   }
 783   unless ($out->{IMG}) {
 784     $self->{ERRSTR} = $self->_error_as_msg;
 785     return;
 786   }
 787
 788   return $out;
 789 }
 790
 791 # Sets an image to a certain size and channel number
 792 # if there was previously data in the image it is discarded
 793
 794 sub img_set {
 795   my $self=shift;
 796
 797   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
 798
 799   if (defined($self->{IMG})) {
 800     # let IIM_DESTROY destroy it, it's possible this image is
 801     # referenced from a virtual image (like masked)
 802     #i_img_destroy($self->{IMG});
 803     undef($self->{IMG});
 804   }
 805
 806   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
 807     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
 808                                  $hsh{maxcolors} || 256);
 809   }
 810   elsif ($hsh{bits} eq 'double') {
 811     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 812   }
 813   elsif ($hsh{bits} == 16) {
 814     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 815   }
 816   else {
 817     $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
 818                                      $hsh{'channels'});
 819   }
 820
 821   unless ($self->{IMG}) {
 822     $self->{ERRSTR} = Imager->_error_as_msg();
 823     return;
 824   }
 825
 826   $self;
 827 }
 828
 829 # created a masked version of the current image
 830 sub masked {
 831   my $self = shift;
 832
 833   $self or return undef;
 834   my %opts = (left    => 0,
 835               top     => 0,
 836               right   => $self->getwidth,
 837               bottom  => $self->getheight,
 838               @_);
 839   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
 840
 841   my $result = Imager->new;
 842   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
 843                                     $opts{top}, $opts{right} - $opts{left},
 844                                     $opts{bottom} - $opts{top});
 845   # keep references to the mask and base images so they don't
 846   # disappear on us
 847   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
 848
 849   $result;
 850 }
 851
 852 # convert an RGB image into a paletted image
 853 sub to_paletted {
 854   my $self = shift;
 855   my $opts;
 856   if (@_ != 1 && !ref $_[0]) {
 857     $opts = { @_ };
 858   }
 859   else {
 860     $opts = shift;
 861   }
 862
 863   unless (defined wantarray) {
 864     my @caller = caller;
 865     warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
 866     return;
 867   }
 868
 869   my $result = Imager->new;
 870   $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
 871
 872   #print "Type ", i_img_type($result->{IMG}), "\n";
 873
 874   if ($result->{IMG}) {
 875     return $result;
 876   }
 877   else {
 878     $self->{ERRSTR} = $self->_error_as_msg;
 879     return;
 880   }
 881 }
 882
 883 # convert a paletted (or any image) to an 8-bit/channel RGB images
 884 sub to_rgb8 {
 885   my $self = shift;
 886   my $result;
 887
 888   unless (defined wantarray) {
 889     my @caller = caller;
 890     warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
 891     return;
 892   }
 893
 894   if ($self->{IMG}) {
 895     $result = Imager->new;
 896     $result->{IMG} = i_img_to_rgb($self->{IMG})
 897       or undef $result;
 898   }
 899
 900   return $result;
 901 }
 902
 903 # convert a paletted (or any image) to an 8-bit/channel RGB images
 904 sub to_rgb16 {
 905   my $self = shift;
 906   my $result;
 907
 908   unless (defined wantarray) {
 909     my @caller = caller;
 910     warn "to_rgb16() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
 911     return;
 912   }
 913
 914   if ($self->{IMG}) {
 915     $result = Imager->new;
 916     $result->{IMG} = i_img_to_rgb16($self->{IMG})
 917       or undef $result;
 918   }
 919
 920   return $result;
 921 }
 922
 923 sub addcolors {
 924   my $self = shift;
 925   my %opts = (colors=>[], @_);
 926
 927   unless ($self->{IMG}) {
 928     $self->_set_error("empty input image");
 929     return;
 930   }
 931
 932   my @colors = @{$opts{colors}}
 933     or return undef;
 934
 935   for my $color (@colors) {
 936     $color = _color($color);
 937     unless ($color) {
 938       $self->_set_error($Imager::ERRSTR);
 939       return;
 940     }
 941   }
 942
 943   return i_addcolors($self->{IMG}, @colors);
 944 }
 945
 946 sub setcolors {
 947   my $self = shift;
 948   my %opts = (start=>0, colors=>[], @_);
 949
 950   unless ($self->{IMG}) {
 951     $self->_set_error("empty input image");
 952     return;
 953   }
 954
 955   my @colors = @{$opts{colors}}
 956     or return undef;
 957
 958   for my $color (@colors) {
 959     $color = _color($color);
 960     unless ($color) {
 961       $self->_set_error($Imager::ERRSTR);
 962       return;
 963     }
 964   }
 965
 966   return i_setcolors($self->{IMG}, $opts{start}, @colors);
 967 }
 968
 969 sub getcolors {
 970   my $self = shift;
 971   my %opts = @_;
 972   if (!exists $opts{start} && !exists $opts{count}) {
 973     # get them all
 974     $opts{start} = 0;
 975     $opts{count} = $self->colorcount;
 976   }
 977   elsif (!exists $opts{count}) {
 978     $opts{count} = 1;
 979   }
 980   elsif (!exists $opts{start}) {
 981     $opts{start} = 0;
 982   }
 983
 984   $self->{IMG} and
 985     return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
 986 }
 987
 988 sub colorcount {
 989   i_colorcount($_[0]{IMG});
 990 }
 991
 992 sub maxcolors {
 993   i_maxcolors($_[0]{IMG});
 994 }
 995
 996 sub findcolor {
 997   my $self = shift;
 998   my %opts = @_;
 999   $opts{color} or return undef;
1000
1001   $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
1002 }
1003
1004 sub bits {
1005   my $self = shift;
1006   my $bits = $self->{IMG} && i_img_bits($self->{IMG});
1007   if ($bits && $bits == length(pack("d", 1)) * 8) {
1008     $bits = 'double';
1009   }
1010   $bits;
1011 }
1012
1013 sub type {
1014   my $self = shift;
1015   if ($self->{IMG}) {
1016     return i_img_type($self->{IMG}) ? "paletted" : "direct";
1017   }
1018 }
1019
1020 sub virtual {
1021   my $self = shift;
1022   $self->{IMG} and i_img_virtual($self->{IMG});
1023 }
1024
1025 sub tags {
1026   my ($self, %opts) = @_;
1027
1028   $self->{IMG} or return;
1029
1030   if (defined $opts{name}) {
1031     my @result;
1032     my $start = 0;
1033     my $found;
1034     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1035       push @result, (i_tags_get($self->{IMG}, $found))[1];
1036       $start = $found+1;
1037     }
1038     return wantarray ? @result : $result[0];
1039   }
1040   elsif (defined $opts{code}) {
1041     my @result;
1042     my $start = 0;
1043     my $found;
1044     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1045       push @result, (i_tags_get($self->{IMG}, $found))[1];
1046       $start = $found+1;
1047     }
1048     return @result;
1049   }
1050   else {
1051     if (wantarray) {
1052       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1053     }
1054     else {
1055       return i_tags_count($self->{IMG});
1056     }
1057   }
1058 }
1059
1060 sub addtag {
1061   my $self = shift;
1062   my %opts = @_;
1063
1064   return -1 unless $self->{IMG};
1065   if ($opts{name}) {
1066     if (defined $opts{value}) {
1067       if ($opts{value} =~ /^\d+$/) {
1068         # add as a number
1069         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1070       }
1071       else {
1072         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1073       }
1074     }
1075     elsif (defined $opts{data}) {
1076       # force addition as a string
1077       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1078     }
1079     else {
1080       $self->{ERRSTR} = "No value supplied";
1081       return undef;
1082     }
1083   }
1084   elsif ($opts{code}) {
1085     if (defined $opts{value}) {
1086       if ($opts{value} =~ /^\d+$/) {
1087         # add as a number
1088         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1089       }
1090       else {
1091         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1092       }
1093     }
1094     elsif (defined $opts{data}) {
1095       # force addition as a string
1096       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1097     }
1098     else {
1099       $self->{ERRSTR} = "No value supplied";
1100       return undef;
1101     }
1102   }
1103   else {
1104     return undef;
1105   }
1106 }
1107
1108 sub deltag {
1109   my $self = shift;
1110   my %opts = @_;
1111
1112   return 0 unless $self->{IMG};
1113
1114   if (defined $opts{'index'}) {
1115     return i_tags_delete($self->{IMG}, $opts{'index'});
1116   }
1117   elsif (defined $opts{name}) {
1118     return i_tags_delbyname($self->{IMG}, $opts{name});
1119   }
1120   elsif (defined $opts{code}) {
1121     return i_tags_delbycode($self->{IMG}, $opts{code});
1122   }
1123   else {
1124     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1125     return 0;
1126   }
1127 }
1128
1129 sub settag {
1130   my ($self, %opts) = @_;
1131
1132   if ($opts{name}) {
1133     $self->deltag(name=>$opts{name});
1134     return $self->addtag(name=>$opts{name}, value=>$opts{value});
1135   }
1136   elsif (defined $opts{code}) {
1137     $self->deltag(code=>$opts{code});
1138     return $self->addtag(code=>$opts{code}, value=>$opts{value});
1139   }
1140   else {
1141     return undef;
1142   }
1143 }
1144
1145
1146 sub _get_reader_io {
1147   my ($self, $input) = @_;
1148
1149   if ($input->{io}) {
1150     return $input->{io}, undef;
1151   }
1152   elsif ($input->{fd}) {
1153     return io_new_fd($input->{fd});
1154   }
1155   elsif ($input->{fh}) {
1156     my $fd = fileno($input->{fh});
1157     unless ($fd) {
1158       $self->_set_error("Handle in fh option not opened");
1159       return;
1160     }
1161     return io_new_fd($fd);
1162   }
1163   elsif ($input->{file}) {
1164     my $file = IO::File->new($input->{file}, "r");
1165     unless ($file) {
1166       $self->_set_error("Could not open $input->{file}: $!");
1167       return;
1168     }
1169     binmode $file;
1170     return (io_new_fd(fileno($file)), $file);
1171   }
1172   elsif ($input->{data}) {
1173     return io_new_buffer($input->{data});
1174   }
1175   elsif ($input->{callback} || $input->{readcb}) {
1176     if (!$input->{seekcb}) {
1177       $self->_set_error("Need a seekcb parameter");
1178     }
1179     if ($input->{maxbuffer}) {
1180       return io_new_cb($input->{writecb},
1181                        $input->{callback} || $input->{readcb},
1182                        $input->{seekcb}, $input->{closecb},
1183                        $input->{maxbuffer});
1184     }
1185     else {
1186       return io_new_cb($input->{writecb},
1187                        $input->{callback} || $input->{readcb},
1188                        $input->{seekcb}, $input->{closecb});
1189     }
1190   }
1191   else {
1192     $self->_set_error("file/fd/fh/data/callback parameter missing");
1193     return;
1194   }
1195 }
1196
1197 sub _get_writer_io {
1198   my ($self, $input, $type) = @_;
1199
1200   if ($input->{io}) {
1201     return $input->{io};
1202   }
1203   elsif ($input->{fd}) {
1204     return io_new_fd($input->{fd});
1205   }
1206   elsif ($input->{fh}) {
1207     my $fd = fileno($input->{fh});
1208     unless ($fd) {
1209       $self->_set_error("Handle in fh option not opened");
1210       return;
1211     }
1212     # flush it
1213     my $oldfh = select($input->{fh});
1214     # flush anything that's buffered, and make sure anything else is flushed
1215     $| = 1;
1216     select($oldfh);
1217     return io_new_fd($fd);
1218   }
1219   elsif ($input->{file}) {
1220     my $fh = new IO::File($input->{file},"w+");
1221     unless ($fh) {
1222       $self->_set_error("Could not open file $input->{file}: $!");
1223       return;
1224     }
1225     binmode($fh) or die;
1226     return (io_new_fd(fileno($fh)), $fh);
1227   }
1228   elsif ($input->{data}) {
1229     return io_new_bufchain();
1230   }
1231   elsif ($input->{callback} || $input->{writecb}) {
1232     if ($input->{maxbuffer}) {
1233       return io_new_cb($input->{callback} || $input->{writecb},
1234                        $input->{readcb},
1235                        $input->{seekcb}, $input->{closecb},
1236                        $input->{maxbuffer});
1237     }
1238     else {
1239       return io_new_cb($input->{callback} || $input->{writecb},
1240                        $input->{readcb},
1241                        $input->{seekcb}, $input->{closecb});
1242     }
1243   }
1244   else {
1245     $self->_set_error("file/fd/fh/data/callback parameter missing");
1246     return;
1247   }
1248 }
1249
1250 # Read an image from file
1251
1252 sub read {
1253   my $self = shift;
1254   my %input=@_;
1255
1256   if (defined($self->{IMG})) {
1257     # let IIM_DESTROY do the destruction, since the image may be
1258     # referenced from elsewhere
1259     #i_img_destroy($self->{IMG});
1260     undef($self->{IMG});
1261   }
1262
1263   my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1264
1265   unless ($input{'type'}) {
1266     $input{'type'} = i_test_format_probe($IO, -1);
1267   }
1268
1269   unless ($input{'type'}) {
1270           $self->_set_error('type parameter missing and not possible to guess from extension');
1271     return undef;
1272   }
1273
1274   _reader_autoload($input{type});
1275
1276   if ($readers{$input{type}} && $readers{$input{type}}{single}) {
1277     return $readers{$input{type}}{single}->($self, $IO, %input);
1278   }
1279
1280   unless ($formats{$input{'type'}}) {
1281     $self->_set_error("format '$input{'type'}' not supported");
1282     return;
1283   }
1284
1285   # Setup data source
1286   if ( $input{'type'} eq 'jpeg' ) {
1287     ($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
1288     if ( !defined($self->{IMG}) ) {
1289       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1290     }
1291     $self->{DEBUG} && print "loading a jpeg file\n";
1292     return $self;
1293   }
1294
1295   my $allow_incomplete = $input{allow_incomplete};
1296   defined $allow_incomplete or $allow_incomplete = 0;
1297
1298   if ( $input{'type'} eq 'tiff' ) {
1299     my $page = $input{'page'};
1300     defined $page or $page = 0;
1301     $self->{IMG}=i_readtiff_wiol( $IO, $allow_incomplete, $page );
1302     if ( !defined($self->{IMG}) ) {
1303       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1304     }
1305     $self->{DEBUG} && print "loading a tiff file\n";
1306     return $self;
1307   }
1308
1309   if ( $input{'type'} eq 'pnm' ) {
1310     $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
1311     if ( !defined($self->{IMG}) ) {
1312       $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1313       return undef;
1314     }
1315     $self->{DEBUG} && print "loading a pnm file\n";
1316     return $self;
1317   }
1318
1319   if ( $input{'type'} eq 'png' ) {
1320     $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1321     if ( !defined($self->{IMG}) ) {
1322       $self->{ERRSTR} = $self->_error_as_msg();
1323       return undef;
1324     }
1325     $self->{DEBUG} && print "loading a png file\n";
1326   }
1327
1328   if ( $input{'type'} eq 'bmp' ) {
1329     $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
1330     if ( !defined($self->{IMG}) ) {
1331       $self->{ERRSTR}=$self->_error_as_msg();
1332       return undef;
1333     }
1334     $self->{DEBUG} && print "loading a bmp file\n";
1335   }
1336
1337   if ( $input{'type'} eq 'gif' ) {
1338     if ($input{colors} && !ref($input{colors})) {
1339       # must be a reference to a scalar that accepts the colour map
1340       $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1341       return undef;
1342     }
1343     if ($input{'gif_consolidate'}) {
1344       if ($input{colors}) {
1345         my $colors;
1346         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1347         if ($colors) {
1348           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1349         }
1350       }
1351       else {
1352         $self->{IMG} =i_readgif_wiol( $IO );
1353       }
1354     }
1355     else {
1356       my $page = $input{'page'};
1357       defined $page or $page = 0;
1358       $self->{IMG} = i_readgif_single_wiol( $IO, $page );
1359       if ($self->{IMG} && $input{colors}) {
1360         ${ $input{colors} } =
1361           [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ];
1362       }
1363     }
1364
1365     if ( !defined($self->{IMG}) ) {
1366       $self->{ERRSTR}=$self->_error_as_msg();
1367       return undef;
1368     }
1369     $self->{DEBUG} && print "loading a gif file\n";
1370   }
1371
1372   if ( $input{'type'} eq 'tga' ) {
1373     $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1374     if ( !defined($self->{IMG}) ) {
1375       $self->{ERRSTR}=$self->_error_as_msg();
1376       return undef;
1377     }
1378     $self->{DEBUG} && print "loading a tga file\n";
1379   }
1380
1381   if ( $input{'type'} eq 'raw' ) {
1382     my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1383
1384     if ( !($params{xsize} && $params{ysize}) ) {
1385       $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1386       return undef;
1387     }
1388
1389     $self->{IMG} = i_readraw_wiol( $IO,
1390                                    $params{xsize},
1391                                    $params{ysize},
1392                                    $params{datachannels},
1393                                    $params{storechannels},
1394                                    $params{interleave});
1395     if ( !defined($self->{IMG}) ) {
1396       $self->{ERRSTR}=$self->_error_as_msg();
1397       return undef;
1398     }
1399     $self->{DEBUG} && print "loading a raw file\n";
1400   }
1401
1402   return $self;
1403 }
1404
1405 sub register_reader {
1406   my ($class, %opts) = @_;
1407
1408   defined $opts{type}
1409     or die "register_reader called with no type parameter\n";
1410
1411   my $type = $opts{type};
1412
1413   defined $opts{single} || defined $opts{multiple}
1414     or die "register_reader called with no single or multiple parameter\n";
1415
1416   $readers{$type} = {  };
1417   if ($opts{single}) {
1418     $readers{$type}{single} = $opts{single};
1419   }
1420   if ($opts{multiple}) {
1421     $readers{$type}{multiple} = $opts{multiple};
1422   }
1423
1424   return 1;
1425 }
1426
1427 sub register_writer {
1428   my ($class, %opts) = @_;
1429
1430   defined $opts{type}
1431     or die "register_writer called with no type parameter\n";
1432
1433   my $type = $opts{type};
1434
1435   defined $opts{single} || defined $opts{multiple}
1436     or die "register_writer called with no single or multiple parameter\n";
1437
1438   $writers{$type} = {  };
1439   if ($opts{single}) {
1440     $writers{$type}{single} = $opts{single};
1441   }
1442   if ($opts{multiple}) {
1443     $writers{$type}{multiple} = $opts{multiple};
1444   }
1445
1446   return 1;
1447 }
1448
1449 # probes for an Imager::File::whatever module
1450 sub _reader_autoload {
1451   my $type = shift;
1452
1453   return if $formats{$type} || $readers{$type};
1454
1455   return unless $type =~ /^\w+$/;
1456
1457   my $file = "Imager/File/\U$type\E.pm";
1458
1459   unless ($attempted_to_load{$file}) {
1460     eval {
1461       ++$attempted_to_load{$file};
1462       require $file;
1463     };
1464     if ($@) {
1465       # try to get a reader specific module
1466       my $file = "Imager/File/\U$type\EReader.pm";
1467       unless ($attempted_to_load{$file}) {
1468         eval {
1469           ++$attempted_to_load{$file};
1470           require $file;
1471         };
1472       }
1473     }
1474   }
1475 }
1476
1477 # probes for an Imager::File::whatever module
1478 sub _writer_autoload {
1479   my $type = shift;
1480
1481   return if $formats{$type} || $readers{$type};
1482
1483   return unless $type =~ /^\w+$/;
1484
1485   my $file = "Imager/File/\U$type\E.pm";
1486
1487   unless ($attempted_to_load{$file}) {
1488     eval {
1489       ++$attempted_to_load{$file};
1490       require $file;
1491     };
1492     if ($@) {
1493       # try to get a writer specific module
1494       my $file = "Imager/File/\U$type\EWriter.pm";
1495       unless ($attempted_to_load{$file}) {
1496         eval {
1497           ++$attempted_to_load{$file};
1498           require $file;
1499         };
1500       }
1501     }
1502   }
1503 }
1504
1505 sub _fix_gif_positions {
1506   my ($opts, $opt, $msg, @imgs) = @_;
1507
1508   my $positions = $opts->{'gif_positions'};
1509   my $index = 0;
1510   for my $pos (@$positions) {
1511     my ($x, $y) = @$pos;
1512     my $img = $imgs[$index++];
1513     $img->settag(name=>'gif_left', value=>$x);
1514     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1515   }
1516   $$msg .= "replaced with the gif_left and gif_top tags";
1517 }
1518
1519 my %obsolete_opts =
1520   (
1521    gif_each_palette=>'gif_local_map',
1522    interlace       => 'gif_interlace',
1523    gif_delays => 'gif_delay',
1524    gif_positions => \&_fix_gif_positions,
1525    gif_loop_count => 'gif_loop',
1526   );
1527
1528 sub _set_opts {
1529   my ($self, $opts, $prefix, @imgs) = @_;
1530
1531   for my $opt (keys %$opts) {
1532     my $tagname = $opt;
1533     if ($obsolete_opts{$opt}) {
1534       my $new = $obsolete_opts{$opt};
1535       my $msg = "Obsolete option $opt ";
1536       if (ref $new) {
1537         $new->($opts, $opt, \$msg, @imgs);
1538       }
1539       else {
1540         $msg .= "replaced with the $new tag ";
1541         $tagname = $new;
1542       }
1543       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1544       warn $msg if $warn_obsolete && $^W;
1545     }
1546     next unless $tagname =~ /^\Q$prefix/;
1547     my $value = $opts->{$opt};
1548     if (ref $value) {
1549       if (UNIVERSAL::isa($value, "Imager::Color")) {
1550         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1551         for my $img (@imgs) {
1552           $img->settag(name=>$tagname, value=>$tag);
1553         }
1554       }
1555       elsif (ref($value) eq 'ARRAY') {
1556         for my $i (0..$#$value) {
1557           my $val = $value->[$i];
1558           if (ref $val) {
1559             if (UNIVERSAL::isa($val, "Imager::Color")) {
1560               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1561               $i < @imgs and
1562                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1563             }
1564             else {
1565               $self->_set_error("Unknown reference type " . ref($value) .
1566                                 " supplied in array for $opt");
1567               return;
1568             }
1569           }
1570           else {
1571             $i < @imgs
1572               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1573           }
1574         }
1575       }
1576       else {
1577         $self->_set_error("Unknown reference type " . ref($value) .
1578                           " supplied for $opt");
1579         return;
1580       }
1581     }
1582     else {
1583       # set it as a tag for every image
1584       for my $img (@imgs) {
1585         $img->settag(name=>$tagname, value=>$value);
1586       }
1587     }
1588   }
1589
1590   return 1;
1591 }
1592
1593 # Write an image to file
1594 sub write {
1595   my $self = shift;
1596   my %input=(jpegquality=>75,
1597              gifquant=>'mc',
1598              lmdither=>6.0,
1599              lmfixed=>[],
1600              idstring=>"",
1601              compress=>1,
1602              wierdpack=>0,
1603              fax_fine=>1, @_);
1604   my $rc;
1605
1606   $self->_set_opts(\%input, "i_", $self)
1607     or return undef;
1608
1609   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1610
1611   if (!$input{'type'} and $input{file}) {
1612     $input{'type'}=$FORMATGUESS->($input{file});
1613   }
1614   if (!$input{'type'}) {
1615     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1616     return undef;
1617   }
1618
1619   _writer_autoload($input{type});
1620
1621   my ($IO, $fh);
1622   if ($writers{$input{type}} && $writers{$input{type}}{single}) {
1623     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1624       or return undef;
1625
1626     $writers{$input{type}}{single}->($self, $IO, %input)
1627       or return undef;
1628   }
1629   else {
1630     if (!$formats{$input{'type'}}) {
1631       $self->{ERRSTR}='format not supported';
1632       return undef;
1633     }
1634
1635     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1636       or return undef;
1637
1638     if ($input{'type'} eq 'tiff') {
1639       $self->_set_opts(\%input, "tiff_", $self)
1640         or return undef;
1641       $self->_set_opts(\%input, "exif_", $self)
1642         or return undef;
1643
1644       if (defined $input{class} && $input{class} eq 'fax') {
1645         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1646           $self->{ERRSTR} = $self->_error_as_msg();
1647           return undef;
1648         }
1649       } else {
1650         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1651           $self->{ERRSTR} = $self->_error_as_msg();
1652           return undef;
1653         }
1654       }
1655     } elsif ( $input{'type'} eq 'pnm' ) {
1656       $self->_set_opts(\%input, "pnm_", $self)
1657         or return undef;
1658       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1659         $self->{ERRSTR} = $self->_error_as_msg();
1660         return undef;
1661       }
1662       $self->{DEBUG} && print "writing a pnm file\n";
1663     } elsif ( $input{'type'} eq 'raw' ) {
1664       $self->_set_opts(\%input, "raw_", $self)
1665         or return undef;
1666       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1667         $self->{ERRSTR} = $self->_error_as_msg();
1668         return undef;
1669       }
1670       $self->{DEBUG} && print "writing a raw file\n";
1671     } elsif ( $input{'type'} eq 'png' ) {
1672       $self->_set_opts(\%input, "png_", $self)
1673         or return undef;
1674       if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1675         $self->{ERRSTR}='unable to write png image';
1676         return undef;
1677       }
1678       $self->{DEBUG} && print "writing a png file\n";
1679     } elsif ( $input{'type'} eq 'jpeg' ) {
1680       $self->_set_opts(\%input, "jpeg_", $self)
1681         or return undef;
1682       $self->_set_opts(\%input, "exif_", $self)
1683         or return undef;
1684       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1685         $self->{ERRSTR} = $self->_error_as_msg();
1686         return undef;
1687       }
1688       $self->{DEBUG} && print "writing a jpeg file\n";
1689     } elsif ( $input{'type'} eq 'bmp' ) {
1690       $self->_set_opts(\%input, "bmp_", $self)
1691         or return undef;
1692       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1693         $self->{ERRSTR} = $self->_error_as_msg;
1694         return undef;
1695       }
1696       $self->{DEBUG} && print "writing a bmp file\n";
1697     } elsif ( $input{'type'} eq 'tga' ) {
1698       $self->_set_opts(\%input, "tga_", $self)
1699         or return undef;
1700
1701       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1702         $self->{ERRSTR}=$self->_error_as_msg();
1703         return undef;
1704       }
1705       $self->{DEBUG} && print "writing a tga file\n";
1706     } elsif ( $input{'type'} eq 'gif' ) {
1707       $self->_set_opts(\%input, "gif_", $self)
1708         or return undef;
1709       # compatibility with the old interfaces
1710       if ($input{gifquant} eq 'lm') {
1711         $input{make_colors} = 'addi';
1712         $input{translate} = 'perturb';
1713         $input{perturb} = $input{lmdither};
1714       } elsif ($input{gifquant} eq 'gen') {
1715         # just pass options through
1716       } else {
1717         $input{make_colors} = 'webmap'; # ignored
1718         $input{translate} = 'giflib';
1719       }
1720       if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1721         $self->{ERRSTR} = $self->_error_as_msg;
1722         return;
1723       }
1724     }
1725   }
1726
1727   if (exists $input{'data'}) {
1728     my $data = io_slurp($IO);
1729     if (!$data) {
1730       $self->{ERRSTR}='Could not slurp from buffer';
1731       return undef;
1732     }
1733     ${$input{data}} = $data;
1734   }
1735   return $self;
1736 }
1737
1738 sub write_multi {
1739   my ($class, $opts, @images) = @_;
1740
1741   my $type = $opts->{type};
1742
1743   if (!$type && $opts->{'file'}) {
1744     $type = $FORMATGUESS->($opts->{'file'});
1745   }
1746   unless ($type) {
1747     $class->_set_error('type parameter missing and not possible to guess from extension');
1748     return;
1749   }
1750   # translate to ImgRaw
1751   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1752     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1753     return 0;
1754   }
1755   $class->_set_opts($opts, "i_", @images)
1756     or return;
1757   my @work = map $_->{IMG}, @images;
1758
1759   _writer_autoload($type);
1760
1761   my ($IO, $file);
1762   if ($writers{$type} && $writers{$type}{multiple}) {
1763     ($IO, $file) = $class->_get_writer_io($opts, $type)
1764       or return undef;
1765
1766     $writers{$type}{multiple}->($class, $IO, $opts, @images)
1767       or return undef;
1768   }
1769   else {
1770     if (!$formats{$type}) {
1771       $class->_set_error("format $type not supported");
1772       return undef;
1773     }
1774
1775     ($IO, $file) = $class->_get_writer_io($opts, $type)
1776       or return undef;
1777
1778     if ($type eq 'gif') {
1779       $class->_set_opts($opts, "gif_", @images)
1780         or return;
1781       my $gif_delays = $opts->{gif_delays};
1782       local $opts->{gif_delays} = $gif_delays;
1783       if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1784         # assume the caller wants the same delay for each frame
1785         $opts->{gif_delays} = [ ($gif_delays) x @images ];
1786       }
1787       unless (i_writegif_wiol($IO, $opts, @work)) {
1788         $class->_set_error($class->_error_as_msg());
1789         return undef;
1790       }
1791     }
1792     elsif ($type eq 'tiff') {
1793       $class->_set_opts($opts, "tiff_", @images)
1794         or return;
1795       $class->_set_opts($opts, "exif_", @images)
1796         or return;
1797       my $res;
1798       $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1799       if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1800         $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1801       }
1802       else {
1803         $res = i_writetiff_multi_wiol($IO, @work);
1804       }
1805       unless ($res) {
1806         $class->_set_error($class->_error_as_msg());
1807         return undef;
1808       }
1809     }
1810     else {
1811       if (@images == 1) {
1812         unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1813           return 1;
1814         }
1815       }
1816       else {
1817         $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1818         return 0;
1819       }
1820     }
1821   }
1822
1823   if (exists $opts->{'data'}) {
1824     my $data = io_slurp($IO);
1825     if (!$data) {
1826       Imager->_set_error('Could not slurp from buffer');
1827       return undef;
1828     }
1829     ${$opts->{data}} = $data;
1830   }
1831   return 1;
1832 }
1833
1834 # read multiple images from a file
1835 sub read_multi {
1836   my ($class, %opts) = @_;
1837
1838   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1839     or return;
1840
1841   my $type = $opts{'type'};
1842   unless ($type) {
1843     $type = i_test_format_probe($IO, -1);
1844   }
1845
1846   if ($opts{file} && !$type) {
1847     # guess the type
1848     $type = $FORMATGUESS->($opts{file});
1849   }
1850
1851   unless ($type) {
1852     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1853     return;
1854   }
1855
1856   _reader_autoload($type);
1857
1858   if ($readers{$type} && $readers{$type}{multiple}) {
1859     return $readers{$type}{multiple}->($IO, %opts);
1860   }
1861
1862   if ($type eq 'gif') {
1863     my @imgs;
1864     @imgs = i_readgif_multi_wiol($IO);
1865     if (@imgs) {
1866       return map {
1867         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1868       } @imgs;
1869     }
1870     else {
1871       $ERRSTR = _error_as_msg();
1872       return;
1873     }
1874   }
1875   elsif ($type eq 'tiff') {
1876     my @imgs = i_readtiff_multi_wiol($IO, -1);
1877     if (@imgs) {
1878       return map {
1879         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1880       } @imgs;
1881     }
1882     else {
1883       $ERRSTR = _error_as_msg();
1884       return;
1885     }
1886   }
1887   else {
1888     my $img = Imager->new;
1889     if ($img->read(%opts, io => $IO, type => $type)) {
1890       return ( $img );
1891     }
1892   }
1893
1894   $ERRSTR = "Cannot read multiple images from $type files";
1895   return;
1896 }
1897
1898 # Destroy an Imager object
1899
1900 sub DESTROY {
1901   my $self=shift;
1902   #    delete $instances{$self};
1903   if (defined($self->{IMG})) {
1904     # the following is now handled by the XS DESTROY method for
1905     # Imager::ImgRaw object
1906     # Re-enabling this will break virtual images
1907     # tested for in t/t020masked.t
1908     # i_img_destroy($self->{IMG});
1909     undef($self->{IMG});
1910   } else {
1911 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1912   }
1913 }
1914
1915 # Perform an inplace filter of an image
1916 # that is the image will be overwritten with the data
1917
1918 sub filter {
1919   my $self=shift;
1920   my %input=@_;
1921   my %hsh;
1922   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1923
1924   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1925
1926   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1927     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1928   }
1929
1930   if ($filters{$input{'type'}}{names}) {
1931     my $names = $filters{$input{'type'}}{names};
1932     for my $name (keys %$names) {
1933       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1934         $input{$name} = $names->{$name}{$input{$name}};
1935       }
1936     }
1937   }
1938   if (defined($filters{$input{'type'}}{defaults})) {
1939     %hsh=( image => $self->{IMG},
1940            imager => $self,
1941            %{$filters{$input{'type'}}{defaults}},
1942            %input );
1943   } else {
1944     %hsh=( image => $self->{IMG},
1945            imager => $self,
1946            %input );
1947   }
1948
1949   my @cs=@{$filters{$input{'type'}}{callseq}};
1950
1951   for(@cs) {
1952     if (!defined($hsh{$_})) {
1953       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1954     }
1955   }
1956
1957   eval {
1958     local $SIG{__DIE__}; # we don't want this processed by confess, etc
1959     &{$filters{$input{'type'}}{callsub}}(%hsh);
1960   };
1961   if ($@) {
1962     chomp($self->{ERRSTR} = $@);
1963     return;
1964   }
1965
1966   my @b=keys %hsh;
1967
1968   $self->{DEBUG} && print "callseq is: @cs\n";
1969   $self->{DEBUG} && print "matching callseq is: @b\n";
1970
1971   return $self;
1972 }
1973
1974 sub register_filter {
1975   my $class = shift;
1976   my %hsh = ( defaults => {}, @_ );
1977
1978   defined $hsh{type}
1979     or die "register_filter() with no type\n";
1980   defined $hsh{callsub}
1981     or die "register_filter() with no callsub\n";
1982   defined $hsh{callseq}
1983     or die "register_filter() with no callseq\n";
1984
1985   exists $filters{$hsh{type}}
1986     and return;
1987
1988   $filters{$hsh{type}} = \%hsh;
1989
1990   return 1;
1991 }
1992
1993 # Scale an image to requested size and return the scaled version
1994
1995 sub scale {
1996   my $self=shift;
1997   my %opts=('type'=>'max',qtype=>'normal',@_);
1998   my $img = Imager->new();
1999   my $tmp = Imager->new();
2000   my ($x_scale, $y_scale);
2001
2002   unless (defined wantarray) {
2003     my @caller = caller;
2004     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2005     return;
2006   }
2007
2008   unless ($self->{IMG}) {
2009     $self->_set_error('empty input image');
2010     return undef;
2011   }
2012
2013   if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2014     $x_scale = $opts{'xscalefactor'};
2015     $y_scale = $opts{'yscalefactor'};
2016   }
2017   elsif ($opts{'xscalefactor'}) {
2018     $x_scale = $opts{'xscalefactor'};
2019     $y_scale = $opts{'scalefactor'} || $x_scale;
2020   }
2021   elsif ($opts{'yscalefactor'}) {
2022     $y_scale = $opts{'yscalefactor'};
2023     $x_scale = $opts{'scalefactor'} || $y_scale;
2024   }
2025   else {
2026     $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2027   }
2028
2029   # work out the scaling
2030   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
2031     my ($xpix, $ypix)=( $opts{xpixels} / $self->getwidth() ,
2032                         $opts{ypixels} / $self->getheight() );
2033     if ($opts{'type'} eq 'min') {
2034       $x_scale = $y_scale = _min($xpix,$ypix);
2035     }
2036     elsif ($opts{'type'} eq 'max') {
2037       $x_scale = $y_scale = _max($xpix,$ypix);
2038     }
2039     elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2040       $x_scale = $xpix;
2041       $y_scale = $ypix;
2042     }
2043     else {
2044       $self->_set_error('invalid value for type parameter');
2045       return undef;
2046     }
2047   } elsif ($opts{xpixels}) {
2048     $x_scale = $y_scale = $opts{xpixels} / $self->getwidth();
2049   }
2050   elsif ($opts{ypixels}) {
2051     $x_scale = $y_scale = $opts{ypixels}/$self->getheight();
2052   }
2053   elsif ($opts{constrain} && ref $opts{constrain}
2054          && $opts{constrain}->can('constrain')) {
2055     # we've been passed an Image::Math::Constrain object or something
2056     # that looks like one
2057     my $scalefactor;
2058     (undef, undef, $scalefactor)
2059       = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2060     unless ($scalefactor) {
2061       $self->_set_error('constrain method failed on constrain parameter');
2062       return undef;
2063     }
2064     $x_scale = $y_scale = $scalefactor;
2065   }
2066
2067   if ($opts{qtype} eq 'normal') {
2068     $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2069     if ( !defined($tmp->{IMG}) ) {
2070       $self->{ERRSTR} = 'unable to scale image';
2071       return undef;
2072     }
2073     $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2074     if ( !defined($img->{IMG}) ) {
2075       $self->{ERRSTR}='unable to scale image';
2076       return undef;
2077     }
2078
2079     return $img;
2080   }
2081   elsif ($opts{'qtype'} eq 'preview') {
2082     $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
2083     if ( !defined($img->{IMG}) ) {
2084       $self->{ERRSTR}='unable to scale image';
2085       return undef;
2086     }
2087     return $img;
2088   }
2089   elsif ($opts{'qtype'} eq 'mixing') {
2090     my $new_width = int(0.5 + $self->getwidth * $x_scale);
2091     my $new_height = int(0.5 + $self->getheight * $y_scale);
2092     $new_width >= 1 or $new_width = 1;
2093     $new_height >= 1 or $new_height = 1;
2094     $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2095     unless ($img->{IMG}) {
2096       $self->_set_error(Imager->_error_as_meg);
2097       return;
2098     }
2099     return $img;
2100   }
2101   else {
2102     $self->_set_error('invalid value for qtype parameter');
2103     return undef;
2104   }
2105 }
2106
2107 # Scales only along the X axis
2108
2109 sub scaleX {
2110   my $self = shift;
2111   my %opts = ( scalefactor=>0.5, @_ );
2112
2113   unless (defined wantarray) {
2114     my @caller = caller;
2115     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2116     return;
2117   }
2118
2119   unless ($self->{IMG}) {
2120     $self->{ERRSTR} = 'empty input image';
2121     return undef;
2122   }
2123
2124   my $img = Imager->new();
2125
2126   my $scalefactor = $opts{scalefactor};
2127
2128   if ($opts{pixels}) {
2129     $scalefactor = $opts{pixels} / $self->getwidth();
2130   }
2131
2132   unless ($self->{IMG}) {
2133     $self->{ERRSTR}='empty input image';
2134     return undef;
2135   }
2136
2137   $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2138
2139   if ( !defined($img->{IMG}) ) {
2140     $self->{ERRSTR} = 'unable to scale image';
2141     return undef;
2142   }
2143
2144   return $img;
2145 }
2146
2147 # Scales only along the Y axis
2148
2149 sub scaleY {
2150   my $self = shift;
2151   my %opts = ( scalefactor => 0.5, @_ );
2152
2153   unless (defined wantarray) {
2154     my @caller = caller;
2155     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2156     return;
2157   }
2158
2159   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2160
2161   my $img = Imager->new();
2162
2163   my $scalefactor = $opts{scalefactor};
2164
2165   if ($opts{pixels}) {
2166     $scalefactor = $opts{pixels} / $self->getheight();
2167   }
2168
2169   unless ($self->{IMG}) {
2170     $self->{ERRSTR} = 'empty input image';
2171     return undef;
2172   }
2173   $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2174
2175   if ( !defined($img->{IMG}) ) {
2176     $self->{ERRSTR} = 'unable to scale image';
2177     return undef;
2178   }
2179
2180   return $img;
2181 }
2182
2183 # Transform returns a spatial transformation of the input image
2184 # this moves pixels to a new location in the returned image.
2185 # NOTE - should make a utility function to check transforms for
2186 # stack overruns
2187
2188 sub transform {
2189   my $self=shift;
2190   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2191   my %opts=@_;
2192   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2193
2194 #  print Dumper(\%opts);
2195 #  xopcopdes
2196
2197   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2198     if (!$I2P) {
2199       eval ("use Affix::Infix2Postfix;");
2200       print $@;
2201       if ( $@ ) {
2202         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2203         return undef;
2204       }
2205       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2206                                              {op=>'-',trans=>'Sub'},
2207                                              {op=>'*',trans=>'Mult'},
2208                                              {op=>'/',trans=>'Div'},
2209                                              {op=>'-','type'=>'unary',trans=>'u-'},
2210                                              {op=>'**'},
2211                                              {op=>'func','type'=>'unary'}],
2212                                      'grouping'=>[qw( \( \) )],
2213                                      'func'=>[qw( sin cos )],
2214                                      'vars'=>[qw( x y )]
2215                                     );
2216     }
2217
2218     @xt=$I2P->translate($opts{'xexpr'});
2219     @yt=$I2P->translate($opts{'yexpr'});
2220
2221     $numre=$I2P->{'numre'};
2222     @pt=(0,0);
2223
2224     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2225     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2226     @{$opts{'parm'}}=@pt;
2227   }
2228
2229 #  print Dumper(\%opts);
2230
2231   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2232     $self->{ERRSTR}='transform: no xopcodes given.';
2233     return undef;
2234   }
2235
2236   @op=@{$opts{'xopcodes'}};
2237   for $iop (@op) {
2238     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2239       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2240       return undef;
2241     }
2242     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2243   }
2244
2245
2246 # yopcopdes
2247
2248   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2249     $self->{ERRSTR}='transform: no yopcodes given.';
2250     return undef;
2251   }
2252
2253   @op=@{$opts{'yopcodes'}};
2254   for $iop (@op) {
2255     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2256       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2257       return undef;
2258     }
2259     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2260   }
2261
2262 #parameters
2263
2264   if ( !exists $opts{'parm'}) {
2265     $self->{ERRSTR}='transform: no parameter arg given.';
2266     return undef;
2267   }
2268
2269 #  print Dumper(\@ropx);
2270 #  print Dumper(\@ropy);
2271 #  print Dumper(\@ropy);
2272
2273   my $img = Imager->new();
2274   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2275   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2276   return $img;
2277 }
2278
2279
2280 sub transform2 {
2281   my ($opts, @imgs) = @_;
2282
2283   require "Imager/Expr.pm";
2284
2285   $opts->{variables} = [ qw(x y) ];
2286   my ($width, $height) = @{$opts}{qw(width height)};
2287   if (@imgs) {
2288     $width ||= $imgs[0]->getwidth();
2289     $height ||= $imgs[0]->getheight();
2290     my $img_num = 1;
2291     for my $img (@imgs) {
2292       $opts->{constants}{"w$img_num"} = $img->getwidth();
2293       $opts->{constants}{"h$img_num"} = $img->getheight();
2294       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2295       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2296       ++$img_num;
2297     }
2298   }
2299   if ($width) {
2300     $opts->{constants}{w} = $width;
2301     $opts->{constants}{cx} = $width/2;
2302   }
2303   else {
2304     $Imager::ERRSTR = "No width supplied";
2305     return;
2306   }
2307   if ($height) {
2308     $opts->{constants}{h} = $height;
2309     $opts->{constants}{cy} = $height/2;
2310   }
2311   else {
2312     $Imager::ERRSTR = "No height supplied";
2313     return;
2314   }
2315   my $code = Imager::Expr->new($opts);
2316   if (!$code) {
2317     $Imager::ERRSTR = Imager::Expr::error();
2318     return;
2319   }
2320   my $channels = $opts->{channels} || 3;
2321   unless ($channels >= 1 && $channels <= 4) {
2322     return Imager->_set_error("channels must be an integer between 1 and 4");
2323   }
2324
2325   my $img = Imager->new();
2326   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2327                              $channels, $code->code(),
2328                              $code->nregs(), $code->cregs(),
2329                              [ map { $_->{IMG} } @imgs ]);
2330   if (!defined $img->{IMG}) {
2331     $Imager::ERRSTR = Imager->_error_as_msg();
2332     return;
2333   }
2334
2335   return $img;
2336 }
2337
2338 sub rubthrough {
2339   my $self=shift;
2340   my %opts=(tx => 0,ty => 0, @_);
2341
2342   unless ($self->{IMG}) {
2343     $self->{ERRSTR}='empty input image';
2344     return undef;
2345   }
2346   unless ($opts{src} && $opts{src}->{IMG}) {
2347     $self->{ERRSTR}='empty input image for src';
2348     return undef;
2349   }
2350
2351   %opts = (src_minx => 0,
2352            src_miny => 0,
2353            src_maxx => $opts{src}->getwidth(),
2354            src_maxy => $opts{src}->getheight(),
2355            %opts);
2356
2357   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx}, $opts{ty},
2358                     $opts{src_minx}, $opts{src_miny},
2359                     $opts{src_maxx}, $opts{src_maxy})) {
2360     $self->_set_error($self->_error_as_msg());
2361     return undef;
2362   }
2363   return $self;
2364 }
2365
2366
2367 sub flip {
2368   my $self  = shift;
2369   my %opts  = @_;
2370   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2371   my $dir;
2372   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2373   $dir = $xlate{$opts{'dir'}};
2374   return $self if i_flipxy($self->{IMG}, $dir);
2375   return ();
2376 }
2377
2378 sub rotate {
2379   my $self = shift;
2380   my %opts = @_;
2381
2382   unless (defined wantarray) {
2383     my @caller = caller;
2384     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2385     return;
2386   }
2387
2388   if (defined $opts{right}) {
2389     my $degrees = $opts{right};
2390     if ($degrees < 0) {
2391       $degrees += 360 * int(((-$degrees)+360)/360);
2392     }
2393     $degrees = $degrees % 360;
2394     if ($degrees == 0) {
2395       return $self->copy();
2396     }
2397     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2398       my $result = Imager->new();
2399       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2400         return $result;
2401       }
2402       else {
2403         $self->{ERRSTR} = $self->_error_as_msg();
2404         return undef;
2405       }
2406     }
2407     else {
2408       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2409       return undef;
2410     }
2411   }
2412   elsif (defined $opts{radians} || defined $opts{degrees}) {
2413     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2414
2415     my $back = $opts{back};
2416     my $result = Imager->new;
2417     if ($back) {
2418       $back = _color($back);
2419       unless ($back) {
2420         $self->_set_error(Imager->errstr);
2421         return undef;
2422       }
2423
2424       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2425     }
2426     else {
2427       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2428     }
2429     if ($result->{IMG}) {
2430       return $result;
2431     }
2432     else {
2433       $self->{ERRSTR} = $self->_error_as_msg();
2434       return undef;
2435     }
2436   }
2437   else {
2438     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2439     return undef;
2440   }
2441 }
2442
2443 sub matrix_transform {
2444   my $self = shift;
2445   my %opts = @_;
2446
2447   unless (defined wantarray) {
2448     my @caller = caller;
2449     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2450     return;
2451   }
2452
2453   if ($opts{matrix}) {
2454     my $xsize = $opts{xsize} || $self->getwidth;
2455     my $ysize = $opts{ysize} || $self->getheight;
2456
2457     my $result = Imager->new;
2458     if ($opts{back}) {
2459       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2460                                           $opts{matrix}, $opts{back})
2461         or return undef;
2462     }
2463     else {
2464       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2465                                           $opts{matrix})
2466         or return undef;
2467     }
2468
2469     return $result;
2470   }
2471   else {
2472     $self->{ERRSTR} = "matrix parameter required";
2473     return undef;
2474   }
2475 }
2476
2477 # blame Leolo :)
2478 *yatf = \&matrix_transform;
2479
2480 # These two are supported for legacy code only
2481
2482 sub i_color_new {
2483   return Imager::Color->new(@_);
2484 }
2485
2486 sub i_color_set {
2487   return Imager::Color::set(@_);
2488 }
2489
2490 # Draws a box between the specified corner points.
2491 sub box {
2492   my $self=shift;
2493   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2494   my $dflcl=i_color_new(255,255,255,255);
2495   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2496
2497   if (exists $opts{'box'}) {
2498     $opts{'xmin'} = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2499     $opts{'xmax'} = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2500     $opts{'ymin'} = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2501     $opts{'ymax'} = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2502   }
2503
2504   if ($opts{filled}) {
2505     my $color = _color($opts{'color'});
2506     unless ($color) {
2507       $self->{ERRSTR} = $Imager::ERRSTR;
2508       return;
2509     }
2510     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2511                  $opts{ymax}, $color);
2512   }
2513   elsif ($opts{fill}) {
2514     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2515       # assume it's a hash ref
2516       require 'Imager/Fill.pm';
2517       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2518         $self->{ERRSTR} = $Imager::ERRSTR;
2519         return undef;
2520       }
2521     }
2522     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2523                 $opts{ymax},$opts{fill}{fill});
2524   }
2525   else {
2526     my $color = _color($opts{'color'});
2527     unless ($color) {
2528       $self->{ERRSTR} = $Imager::ERRSTR;
2529       return;
2530     }
2531     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2532           $color);
2533   }
2534   return $self;
2535 }
2536
2537 sub arc {
2538   my $self=shift;
2539   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2540   my $dflcl=i_color_new(255,255,255,255);
2541   my %opts=(color=>$dflcl,
2542             'r'=>_min($self->getwidth(),$self->getheight())/3,
2543             'x'=>$self->getwidth()/2,
2544             'y'=>$self->getheight()/2,
2545             'd1'=>0, 'd2'=>361, @_);
2546   if ($opts{aa}) {
2547     if ($opts{fill}) {
2548       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2549         # assume it's a hash ref
2550         require 'Imager/Fill.pm';
2551         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2552           $self->{ERRSTR} = $Imager::ERRSTR;
2553           return;
2554         }
2555       }
2556       i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2557                      $opts{'d2'}, $opts{fill}{fill});
2558     }
2559     else {
2560       my $color = _color($opts{'color'});
2561       unless ($color) {
2562         $self->{ERRSTR} = $Imager::ERRSTR;
2563         return;
2564       }
2565       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2566         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2567                     $color);
2568       }
2569       else {
2570         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2571                  $opts{'d1'}, $opts{'d2'}, $color);
2572       }
2573     }
2574   }
2575   else {
2576     if ($opts{fill}) {
2577       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2578         # assume it's a hash ref
2579         require 'Imager/Fill.pm';
2580         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2581           $self->{ERRSTR} = $Imager::ERRSTR;
2582           return;
2583         }
2584       }
2585       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2586                   $opts{'d2'}, $opts{fill}{fill});
2587     }
2588     else {
2589       my $color = _color($opts{'color'});
2590       unless ($color) {
2591         $self->{ERRSTR} = $Imager::ERRSTR;
2592         return;
2593       }
2594       i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2595             $opts{'d1'}, $opts{'d2'}, $color);
2596     }
2597   }
2598
2599   return $self;
2600 }
2601
2602 # Draws a line from one point to the other
2603 # the endpoint is set if the endp parameter is set which it is by default.
2604 # to turn of the endpoint being set use endp=>0 when calling line.
2605
2606 sub line {
2607   my $self=shift;
2608   my $dflcl=i_color_new(0,0,0,0);
2609   my %opts=(color=>$dflcl,
2610             endp => 1,
2611             @_);
2612   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2613
2614   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2615   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2616
2617   my $color = _color($opts{'color'});
2618   unless ($color) {
2619     $self->{ERRSTR} = $Imager::ERRSTR;
2620     return;
2621   }
2622
2623   $opts{antialias} = $opts{aa} if defined $opts{aa};
2624   if ($opts{antialias}) {
2625     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2626               $color, $opts{endp});
2627   } else {
2628     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2629            $color, $opts{endp});
2630   }
2631   return $self;
2632 }
2633
2634 # Draws a line between an ordered set of points - It more or less just transforms this
2635 # into a list of lines.
2636
2637 sub polyline {
2638   my $self=shift;
2639   my ($pt,$ls,@points);
2640   my $dflcl=i_color_new(0,0,0,0);
2641   my %opts=(color=>$dflcl,@_);
2642
2643   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2644
2645   if (exists($opts{points})) { @points=@{$opts{points}}; }
2646   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2647     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2648     }
2649
2650 #  print Dumper(\@points);
2651
2652   my $color = _color($opts{'color'});
2653   unless ($color) {
2654     $self->{ERRSTR} = $Imager::ERRSTR;
2655     return;
2656   }
2657   $opts{antialias} = $opts{aa} if defined $opts{aa};
2658   if ($opts{antialias}) {
2659     for $pt(@points) {
2660       if (defined($ls)) {
2661         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2662       }
2663       $ls=$pt;
2664     }
2665   } else {
2666     for $pt(@points) {
2667       if (defined($ls)) {
2668         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2669       }
2670       $ls=$pt;
2671     }
2672   }
2673   return $self;
2674 }
2675
2676 sub polygon {
2677   my $self = shift;
2678   my ($pt,$ls,@points);
2679   my $dflcl = i_color_new(0,0,0,0);
2680   my %opts = (color=>$dflcl, @_);
2681
2682   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2683
2684   if (exists($opts{points})) {
2685     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2686     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2687   }
2688
2689   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2690     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2691   }
2692
2693   if ($opts{'fill'}) {
2694     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2695       # assume it's a hash ref
2696       require 'Imager/Fill.pm';
2697       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2698         $self->{ERRSTR} = $Imager::ERRSTR;
2699         return undef;
2700       }
2701     }
2702     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2703                     $opts{'fill'}{'fill'});
2704   }
2705   else {
2706     my $color = _color($opts{'color'});
2707     unless ($color) {
2708       $self->{ERRSTR} = $Imager::ERRSTR;
2709       return;
2710     }
2711     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2712   }
2713
2714   return $self;
2715 }
2716
2717
2718 # this the multipoint bezier curve
2719 # this is here more for testing that actual usage since
2720 # this is not a good algorithm.  Usually the curve would be
2721 # broken into smaller segments and each done individually.
2722
2723 sub polybezier {
2724   my $self=shift;
2725   my ($pt,$ls,@points);
2726   my $dflcl=i_color_new(0,0,0,0);
2727   my %opts=(color=>$dflcl,@_);
2728
2729   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2730
2731   if (exists $opts{points}) {
2732     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2733     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2734   }
2735
2736   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2737     $self->{ERRSTR}='Missing or invalid points.';
2738     return;
2739   }
2740
2741   my $color = _color($opts{'color'});
2742   unless ($color) {
2743     $self->{ERRSTR} = $Imager::ERRSTR;
2744     return;
2745   }
2746   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2747   return $self;
2748 }
2749
2750 sub flood_fill {
2751   my $self = shift;
2752   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2753   my $rc;
2754
2755   unless (exists $opts{'x'} && exists $opts{'y'}) {
2756     $self->{ERRSTR} = "missing seed x and y parameters";
2757     return undef;
2758   }
2759
2760   if ($opts{border}) {
2761     my $border = _color($opts{border});
2762     unless ($border) {
2763       $self->_set_error($Imager::ERRSTR);
2764       return;
2765     }
2766     if ($opts{fill}) {
2767       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2768         # assume it's a hash ref
2769         require Imager::Fill;
2770         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2771           $self->{ERRSTR} = $Imager::ERRSTR;
2772           return;
2773         }
2774       }
2775       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2776                                  $opts{fill}{fill}, $border);
2777     }
2778     else {
2779       my $color = _color($opts{'color'});
2780       unless ($color) {
2781         $self->{ERRSTR} = $Imager::ERRSTR;
2782         return;
2783       }
2784       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2785                                 $color, $border);
2786     }
2787     if ($rc) {
2788       return $self;
2789     }
2790     else {
2791       $self->{ERRSTR} = $self->_error_as_msg();
2792       return;
2793     }
2794   }
2795   else {
2796     if ($opts{fill}) {
2797       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2798         # assume it's a hash ref
2799         require 'Imager/Fill.pm';
2800         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2801           $self->{ERRSTR} = $Imager::ERRSTR;
2802           return;
2803         }
2804       }
2805       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2806     }
2807     else {
2808       my $color = _color($opts{'color'});
2809       unless ($color) {
2810         $self->{ERRSTR} = $Imager::ERRSTR;
2811         return;
2812       }
2813       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2814     }
2815     if ($rc) {
2816       return $self;
2817     }
2818     else {
2819       $self->{ERRSTR} = $self->_error_as_msg();
2820       return;
2821     }
2822   }
2823 }
2824
2825 sub setpixel {
2826   my $self = shift;
2827
2828   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2829
2830   unless (exists $opts{'x'} && exists $opts{'y'}) {
2831     $self->{ERRSTR} = 'missing x and y parameters';
2832     return undef;
2833   }
2834
2835   my $x = $opts{'x'};
2836   my $y = $opts{'y'};
2837   my $color = _color($opts{color})
2838     or return undef;
2839   if (ref $x && ref $y) {
2840     unless (@$x == @$y) {
2841       $self->{ERRSTR} = 'length of x and y mismatch';
2842       return;
2843     }
2844     my $set = 0;
2845     if ($color->isa('Imager::Color')) {
2846       for my $i (0..$#{$opts{'x'}}) {
2847         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
2848           or ++$set;
2849       }
2850     }
2851     else {
2852       for my $i (0..$#{$opts{'x'}}) {
2853         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
2854           or ++$set;
2855       }
2856     }
2857     $set or return;
2858     return $set;
2859   }
2860   else {
2861     if ($color->isa('Imager::Color')) {
2862       i_ppix($self->{IMG}, $x, $y, $color)
2863         and return;
2864     }
2865     else {
2866       i_ppixf($self->{IMG}, $x, $y, $color)
2867         and return;
2868     }
2869   }
2870
2871   $self;
2872 }
2873
2874 sub getpixel {
2875   my $self = shift;
2876
2877   my %opts = ( "type"=>'8bit', @_);
2878
2879   unless (exists $opts{'x'} && exists $opts{'y'}) {
2880     $self->{ERRSTR} = 'missing x and y parameters';
2881     return undef;
2882   }
2883
2884   my $x = $opts{'x'};
2885   my $y = $opts{'y'};
2886   if (ref $x && ref $y) {
2887     unless (@$x == @$y) {
2888       $self->{ERRSTR} = 'length of x and y mismatch';
2889       return undef;
2890     }
2891     my @result;
2892     if ($opts{"type"} eq '8bit') {
2893       for my $i (0..$#{$opts{'x'}}) {
2894         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2895       }
2896     }
2897     else {
2898       for my $i (0..$#{$opts{'x'}}) {
2899         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2900       }
2901     }
2902     return wantarray ? @result : \@result;
2903   }
2904   else {
2905     if ($opts{"type"} eq '8bit') {
2906       return i_get_pixel($self->{IMG}, $x, $y);
2907     }
2908     else {
2909       return i_gpixf($self->{IMG}, $x, $y);
2910     }
2911   }
2912
2913   $self;
2914 }
2915
2916 sub getscanline {
2917   my $self = shift;
2918   my %opts = ( type => '8bit', x=>0, @_);
2919
2920   $self->_valid_image or return;
2921
2922   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2923
2924   unless (defined $opts{'y'}) {
2925     $self->_set_error("missing y parameter");
2926     return;
2927   }
2928
2929   if ($opts{type} eq '8bit') {
2930     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2931                   $opts{'y'});
2932   }
2933   elsif ($opts{type} eq 'float') {
2934     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2935                   $opts{'y'});
2936   }
2937   elsif ($opts{type} eq 'index') {
2938     unless (i_img_type($self->{IMG})) {
2939       $self->_set_error("type => index only valid on paletted images");
2940       return;
2941     }
2942     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
2943                   $opts{'y'});
2944   }
2945   else {
2946     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2947     return;
2948   }
2949 }
2950
2951 sub setscanline {
2952   my $self = shift;
2953   my %opts = ( x=>0, @_);
2954
2955   $self->_valid_image or return;
2956
2957   unless (defined $opts{'y'}) {
2958     $self->_set_error("missing y parameter");
2959     return;
2960   }
2961
2962   if (!$opts{type}) {
2963     if (ref $opts{pixels} && @{$opts{pixels}}) {
2964       # try to guess the type
2965       if ($opts{pixels}[0]->isa('Imager::Color')) {
2966         $opts{type} = '8bit';
2967       }
2968       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
2969         $opts{type} = 'float';
2970       }
2971       else {
2972         $self->_set_error("missing type parameter and could not guess from pixels");
2973         return;
2974       }
2975     }
2976     else {
2977       # default
2978       $opts{type} = '8bit';
2979     }
2980   }
2981
2982   if ($opts{type} eq '8bit') {
2983     if (ref $opts{pixels}) {
2984       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2985     }
2986     else {
2987       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2988     }
2989   }
2990   elsif ($opts{type} eq 'float') {
2991     if (ref $opts{pixels}) {
2992       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2993     }
2994     else {
2995       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2996     }
2997   }
2998   elsif ($opts{type} eq 'index') {
2999     if (ref $opts{pixels}) {
3000       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3001     }
3002     else {
3003       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3004     }
3005   }
3006   else {
3007     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3008     return;
3009   }
3010 }
3011
3012 sub getsamples {
3013   my $self = shift;
3014   my %opts = ( type => '8bit', x=>0, @_);
3015
3016   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3017
3018   unless (defined $opts{'y'}) {
3019     $self->_set_error("missing y parameter");
3020     return;
3021   }
3022
3023   unless ($opts{channels}) {
3024     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3025   }
3026
3027   if ($opts{type} eq '8bit') {
3028     return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3029                    $opts{y}, @{$opts{channels}});
3030   }
3031   elsif ($opts{type} eq 'float') {
3032     return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3033                     $opts{y}, @{$opts{channels}});
3034   }
3035   else {
3036     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3037     return;
3038   }
3039 }
3040
3041 # make an identity matrix of the given size
3042 sub _identity {
3043   my ($size) = @_;
3044
3045   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3046   for my $c (0 .. ($size-1)) {
3047     $matrix->[$c][$c] = 1;
3048   }
3049   return $matrix;
3050 }
3051
3052 # general function to convert an image
3053 sub convert {
3054   my ($self, %opts) = @_;
3055   my $matrix;
3056
3057   unless (defined wantarray) {
3058     my @caller = caller;
3059     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3060     return;
3061   }
3062
3063   # the user can either specify a matrix or preset
3064   # the matrix overrides the preset
3065   if (!exists($opts{matrix})) {
3066     unless (exists($opts{preset})) {
3067       $self->{ERRSTR} = "convert() needs a matrix or preset";
3068       return;
3069     }
3070     else {
3071       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3072         # convert to greyscale, keeping the alpha channel if any
3073         if ($self->getchannels == 3) {
3074           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3075         }
3076         elsif ($self->getchannels == 4) {
3077           # preserve the alpha channel
3078           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3079                       [ 0,     0,     0,     1 ] ];
3080         }
3081         else {
3082           # an identity
3083           $matrix = _identity($self->getchannels);
3084         }
3085       }
3086       elsif ($opts{preset} eq 'noalpha') {
3087         # strip the alpha channel
3088         if ($self->getchannels == 2 or $self->getchannels == 4) {
3089           $matrix = _identity($self->getchannels);
3090           pop(@$matrix); # lose the alpha entry
3091         }
3092         else {
3093           $matrix = _identity($self->getchannels);
3094         }
3095       }
3096       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3097         # extract channel 0
3098         $matrix = [ [ 1 ] ];
3099       }
3100       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3101         $matrix = [ [ 0, 1 ] ];
3102       }
3103       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3104         $matrix = [ [ 0, 0, 1 ] ];
3105       }
3106       elsif ($opts{preset} eq 'alpha') {
3107         if ($self->getchannels == 2 or $self->getchannels == 4) {
3108           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3109         }
3110         else {
3111           # the alpha is just 1 <shrug>
3112           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3113         }
3114       }
3115       elsif ($opts{preset} eq 'rgb') {
3116         if ($self->getchannels == 1) {
3117           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3118         }
3119         elsif ($self->getchannels == 2) {
3120           # preserve the alpha channel
3121           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3122         }
3123         else {
3124           $matrix = _identity($self->getchannels);
3125         }
3126       }
3127       elsif ($opts{preset} eq 'addalpha') {
3128         if ($self->getchannels == 1) {
3129           $matrix = _identity(2);
3130         }
3131         elsif ($self->getchannels == 3) {
3132           $matrix = _identity(4);
3133         }
3134         else {
3135           $matrix = _identity($self->getchannels);
3136         }
3137       }
3138       else {
3139         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3140         return undef;
3141       }
3142     }
3143   }
3144   else {
3145     $matrix = $opts{matrix};
3146   }
3147
3148   my $new = Imager->new;
3149   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3150   unless ($new->{IMG}) {
3151     # most likely a bad matrix
3152     $self->{ERRSTR} = _error_as_msg();
3153     return undef;
3154   }
3155   return $new;
3156 }
3157
3158
3159 # general function to map an image through lookup tables
3160
3161 sub map {
3162   my ($self, %opts) = @_;
3163   my @chlist = qw( red green blue alpha );
3164
3165   if (!exists($opts{'maps'})) {
3166     # make maps from channel maps
3167     my $chnum;
3168     for $chnum (0..$#chlist) {
3169       if (exists $opts{$chlist[$chnum]}) {
3170         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3171       } elsif (exists $opts{'all'}) {
3172         $opts{'maps'}[$chnum] = $opts{'all'};
3173       }
3174     }
3175   }
3176   if ($opts{'maps'} and $self->{IMG}) {
3177     i_map($self->{IMG}, $opts{'maps'} );
3178   }
3179   return $self;
3180 }
3181
3182 sub difference {
3183   my ($self, %opts) = @_;
3184
3185   defined $opts{mindist} or $opts{mindist} = 0;
3186
3187   defined $opts{other}
3188     or return $self->_set_error("No 'other' parameter supplied");
3189   defined $opts{other}{IMG}
3190     or return $self->_set_error("No image data in 'other' image");
3191
3192   $self->{IMG}
3193     or return $self->_set_error("No image data");
3194
3195   my $result = Imager->new;
3196   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3197                                 $opts{mindist})
3198     or return $self->_set_error($self->_error_as_msg());
3199
3200   return $result;
3201 }
3202
3203 # destructive border - image is shrunk by one pixel all around
3204
3205 sub border {
3206   my ($self,%opts)=@_;
3207   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3208   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3209 }
3210
3211
3212 # Get the width of an image
3213
3214 sub getwidth {
3215   my $self = shift;
3216   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3217   return (i_img_info($self->{IMG}))[0];
3218 }
3219
3220 # Get the height of an image
3221
3222 sub getheight {
3223   my $self = shift;
3224   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3225   return (i_img_info($self->{IMG}))[1];
3226 }
3227
3228 # Get number of channels in an image
3229
3230 sub getchannels {
3231   my $self = shift;
3232   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3233   return i_img_getchannels($self->{IMG});
3234 }
3235
3236 # Get channel mask
3237
3238 sub getmask {
3239   my $self = shift;
3240   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3241   return i_img_getmask($self->{IMG});
3242 }
3243
3244 # Set channel mask
3245
3246 sub setmask {
3247   my $self = shift;
3248   my %opts = @_;
3249   if (!defined($self->{IMG})) {
3250     $self->{ERRSTR} = 'image is empty';
3251     return undef;
3252   }
3253   unless (defined $opts{mask}) {
3254     $self->_set_error("mask parameter required");
3255     return;
3256   }
3257   i_img_setmask( $self->{IMG} , $opts{mask} );
3258
3259   1;
3260 }
3261
3262 # Get number of colors in an image
3263
3264 sub getcolorcount {
3265   my $self=shift;
3266   my %opts=('maxcolors'=>2**30,@_);
3267   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3268   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3269   return ($rc==-1? undef : $rc);
3270 }
3271
3272 # Returns a reference to a hash. The keys are colour named (packed) and the
3273 # values are the number of pixels in this colour.
3274 sub getcolorusagehash {
3275   my $self = shift;
3276
3277   my %opts = ( maxcolors => 2**30, @_ );
3278   my $max_colors = $opts{maxcolors};
3279   unless (defined $max_colors && $max_colors > 0) {
3280     $self->_set_error('maxcolors must be a positive integer');
3281     return;
3282   }
3283
3284   unless (defined $self->{IMG}) {
3285     $self->_set_error('empty input image');
3286     return;
3287   }
3288
3289   my $channels= $self->getchannels;
3290   # We don't want to look at the alpha channel, because some gifs using it
3291   # doesn't define it for every colour (but only for some)
3292   $channels -= 1 if $channels == 2 or $channels == 4;
3293   my %color_use;
3294   my $height = $self->getheight;
3295   for my $y (0 .. $height - 1) {
3296     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3297     while (length $colors) {
3298       $color_use{ substr($colors, 0, $channels, '') }++;
3299     }
3300     keys %color_use > $max_colors
3301       and return;
3302   }
3303   return \%color_use;
3304 }
3305
3306 # This will return a ordered array of the colour usage. Kind of the sorted
3307 # version of the values of the hash returned by getcolorusagehash.
3308 # You might want to add safety checks and change the names, etc...
3309 sub getcolorusage {
3310   my $self = shift;
3311
3312   my %opts = ( maxcolors => 2**30, @_ );
3313   my $max_colors = $opts{maxcolors};
3314   unless (defined $max_colors && $max_colors > 0) {
3315     $self->_set_error('maxcolors must be a positive integer');
3316     return;
3317   }
3318
3319   unless (defined $self->{IMG}) {
3320     $self->_set_error('empty input image');
3321     return undef;
3322   }
3323
3324   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3325 }
3326
3327 # draw string to an image
3328
3329 sub string {
3330   my $self = shift;
3331   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3332
3333   my %input=('x'=>0, 'y'=>0, @_);
3334   defined($input{string}) or $input{string} = $input{text};
3335
3336   unless(defined $input{string}) {
3337     $self->{ERRSTR}="missing required parameter 'string'";
3338     return;
3339   }
3340
3341   unless($input{font}) {
3342     $self->{ERRSTR}="missing required parameter 'font'";
3343     return;
3344   }
3345
3346   unless ($input{font}->draw(image=>$self, %input)) {
3347     return;
3348   }
3349
3350   return $self;
3351 }
3352
3353 sub align_string {
3354   my $self = shift;
3355
3356   my $img;
3357   if (ref $self) {
3358     unless ($self->{IMG}) {
3359       $self->{ERRSTR}='empty input image';
3360       return;
3361     }
3362     $img = $self;
3363   }
3364   else {
3365     $img = undef;
3366   }
3367
3368   my %input=('x'=>0, 'y'=>0, @_);
3369   $input{string}||=$input{text};
3370
3371   unless(exists $input{string}) {
3372     $self->_set_error("missing required parameter 'string'");
3373     return;
3374   }
3375
3376   unless($input{font}) {
3377     $self->_set_error("missing required parameter 'font'");
3378     return;
3379   }
3380
3381   my @result;
3382   unless (@result = $input{font}->align(image=>$img, %input)) {
3383     return;
3384   }
3385
3386   return wantarray ? @result : $result[0];
3387 }
3388
3389 my @file_limit_names = qw/width height bytes/;
3390
3391 sub set_file_limits {
3392   shift;
3393
3394   my %opts = @_;
3395   my %values;
3396
3397   if ($opts{reset}) {
3398     @values{@file_limit_names} = (0) x @file_limit_names;
3399   }
3400   else {
3401     @values{@file_limit_names} = i_get_image_file_limits();
3402   }
3403
3404   for my $key (keys %values) {
3405     defined $opts{$key} and $values{$key} = $opts{$key};
3406   }
3407
3408   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3409 }
3410
3411 sub get_file_limits {
3412   i_get_image_file_limits();
3413 }
3414
3415 # Shortcuts that can be exported
3416
3417 sub newcolor { Imager::Color->new(@_); }
3418 sub newfont  { Imager::Font->new(@_); }
3419
3420 *NC=*newcolour=*newcolor;
3421 *NF=*newfont;
3422
3423 *open=\&read;
3424 *circle=\&arc;
3425
3426
3427 #### Utility routines
3428
3429 sub errstr {
3430   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3431 }
3432
3433 sub _set_error {
3434   my ($self, $msg) = @_;
3435
3436   if (ref $self) {
3437     $self->{ERRSTR} = $msg;
3438   }
3439   else {
3440     $ERRSTR = $msg;
3441   }
3442   return;
3443 }
3444
3445 # Default guess for the type of an image from extension
3446
3447 sub def_guess_type {
3448   my $name=lc(shift);
3449   my $ext;
3450   $ext=($name =~ m/\.([^\.]+)$/)[0];
3451   return 'tiff' if ($ext =~ m/^tiff?$/);
3452   return 'jpeg' if ($ext =~ m/^jpe?g$/);
3453   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
3454   return 'png'  if ($ext eq "png");
3455   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
3456   return 'tga'  if ($ext eq "tga");
3457   return 'sgi'  if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
3458   return 'gif'  if ($ext eq "gif");
3459   return 'raw'  if ($ext eq "raw");
3460   return lc $ext; # best guess
3461   return ();
3462 }
3463
3464 # get the minimum of a list
3465
3466 sub _min {
3467   my $mx=shift;
3468   for(@_) { if ($_<$mx) { $mx=$_; }}
3469   return $mx;
3470 }
3471
3472 # get the maximum of a list
3473
3474 sub _max {
3475   my $mx=shift;
3476   for(@_) { if ($_>$mx) { $mx=$_; }}
3477   return $mx;
3478 }
3479
3480 # string stuff for iptc headers
3481
3482 sub _clean {
3483   my($str)=$_[0];
3484   $str = substr($str,3);
3485   $str =~ s/[\n\r]//g;
3486   $str =~ s/\s+/ /g;
3487   $str =~ s/^\s//;
3488   $str =~ s/\s$//;
3489   return $str;
3490 }
3491
3492 # A little hack to parse iptc headers.
3493
3494 sub parseiptc {
3495   my $self=shift;
3496   my(@sar,$item,@ar);
3497   my($caption,$photogr,$headln,$credit);
3498
3499   my $str=$self->{IPTCRAW};
3500
3501   defined $str
3502     or return;
3503
3504   @ar=split(/8BIM/,$str);
3505
3506   my $i=0;
3507   foreach (@ar) {
3508     if (/^\004\004/) {
3509       @sar=split(/\034\002/);
3510       foreach $item (@sar) {
3511         if ($item =~ m/^x/) {
3512           $caption = _clean($item);
3513           $i++;
3514         }
3515         if ($item =~ m/^P/) {
3516           $photogr = _clean($item);
3517           $i++;
3518         }
3519         if ($item =~ m/^i/) {
3520           $headln = _clean($item);
3521           $i++;
3522         }
3523         if ($item =~ m/^n/) {
3524           $credit = _clean($item);
3525           $i++;
3526         }
3527       }
3528     }
3529   }
3530   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3531 }
3532
3533 sub Inline {
3534   my ($lang) = @_;
3535
3536   $lang eq 'C'
3537     or die "Only C language supported";
3538
3539   require Imager::ExtUtils;
3540   return Imager::ExtUtils->inline_config;
3541 }
3542
3543 1;
3544 __END__
3545 # Below is the stub of documentation for your module. You better edit it!
3546
3547 =head1 NAME
3548
3549 Imager - Perl extension for Generating 24 bit Images
3550
3551 =head1 SYNOPSIS
3552
3553   # Thumbnail example
3554
3555   #!/usr/bin/perl -w
3556   use strict;
3557   use Imager;
3558
3559   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3560   my $file = shift;
3561
3562   my $format;
3563
3564   my $img = Imager->new();
3565   # see Imager::Files for information on the read() method
3566   $img->read(file=>$file) or die $img->errstr();
3567
3568   $file =~ s/\.[^.]*$//;
3569
3570   # Create smaller version
3571   # documented in Imager::Transformations
3572   my $thumb = $img->scale(scalefactor=>.3);
3573
3574   # Autostretch individual channels
3575   $thumb->filter(type=>'autolevels');
3576
3577   # try to save in one of these formats
3578   SAVE:
3579
3580   for $format ( qw( png gif jpg tiff ppm ) ) {
3581     # Check if given format is supported
3582     if ($Imager::formats{$format}) {
3583       $file.="_low.$format";
3584       print "Storing image as: $file\n";
3585       # documented in Imager::Files
3586       $thumb->write(file=>$file) or
3587         die $thumb->errstr;
3588       last SAVE;
3589     }
3590   }
3591
3592 =head1 DESCRIPTION
3593
3594 Imager is a module for creating and altering images.  It can read and
3595 write various image formats, draw primitive shapes like lines,and
3596 polygons, blend multiple images together in various ways, scale, crop,
3597 render text and more.
3598
3599 =head2 Overview of documentation
3600
3601 =over
3602
3603 =item *
3604
3605 Imager - This document - Synopsis, Example, Table of Contents and
3606 Overview.
3607
3608 =item *
3609
3610 L<Imager::Tutorial> - a brief introduction to Imager.
3611
3612 =item *
3613
3614 L<Imager::Cookbook> - how to do various things with Imager.
3615
3616 =item *
3617
3618 L<Imager::ImageTypes> - Basics of constructing image objects with
3619 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
3620 8/16/double bits/channel, color maps, channel masks, image tags, color
3621 quantization.  Also discusses basic image information methods.
3622
3623 =item *
3624
3625 L<Imager::Files> - IO interaction, reading/writing images, format
3626 specific tags.
3627
3628 =item *
3629
3630 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
3631 flood fill.
3632
3633 =item *
3634
3635 L<Imager::Color> - Color specification.
3636
3637 =item *
3638
3639 L<Imager::Fill> - Fill pattern specification.
3640
3641 =item *
3642
3643 L<Imager::Font> - General font rendering, bounding boxes and font
3644 metrics.
3645
3646 =item *
3647
3648 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
3649 blending, pasting, convert and map.
3650
3651 =item *
3652
3653 L<Imager::Engines> - Programmable transformations through
3654 C<transform()>, C<transform2()> and C<matrix_transform()>.
3655
3656 =item *
3657
3658 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
3659 filter plugins.
3660
3661 =item *
3662
3663 L<Imager::Expr> - Expressions for evaluation engine used by
3664 transform2().
3665
3666 =item *
3667
3668 L<Imager::Matrix2d> - Helper class for affine transformations.
3669
3670 =item *
3671
3672 L<Imager::Fountain> - Helper for making gradient profiles.
3673
3674 =item *
3675
3676 L<Imager::API> - using Imager's C API
3677
3678 =item *
3679
3680 L<Imager::APIRef> - API function reference
3681
3682 =item *
3683
3684 L<Imager::Inline> - using Imager's C API from Inline::C
3685
3686 =item *
3687
3688 L<Imager::ExtUtils> - tools to get access to Imager's C API.
3689
3690 =back
3691
3692 =head2 Basic Overview
3693
3694 An Image object is created with C<$img = Imager-E<gt>new()>.
3695 Examples:
3696
3697   $img=Imager->new();                         # create empty image
3698   $img->read(file=>'lena.png',type=>'png') or # read image from file
3699      die $img->errstr();                      # give an explanation
3700                                               # if something failed
3701
3702 or if you want to create an empty image:
3703
3704   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3705
3706 This example creates a completely black image of width 400 and height
3707 300 and 4 channels.
3708
3709 =head1 ERROR HANDLING
3710
3711 In general a method will return false when it fails, if it does use the errstr() method to find out why:
3712
3713 =over
3714
3715 =item errstr
3716
3717 Returns the last error message in that context.
3718
3719 If the last error you received was from calling an object method, such
3720 as read, call errstr() as an object method to find out why:
3721
3722   my $image = Imager->new;
3723   $image->read(file => 'somefile.gif')
3724      or die $image->errstr;
3725
3726 If it was a class method then call errstr() as a class method:
3727
3728   my @imgs = Imager->read_multi(file => 'somefile.gif')
3729     or die Imager->errstr;
3730
3731 Note that in some cases object methods are implemented in terms of
3732 class methods so a failing object method may set both.
3733
3734 =back
3735
3736 The C<Imager-E<gt>new> method is described in detail in
3737 L<Imager::ImageTypes>.
3738
3739 =head1 METHOD INDEX
3740
3741 Where to find information on methods for Imager class objects.
3742
3743 addcolors() -  L<Imager::ImageTypes/addcolors>
3744
3745 addtag() -  L<Imager::ImageTypes/addtag> - add image tags
3746
3747 align_string() - L<Imager::Draw/align_string>
3748
3749 arc() - L<Imager::Draw/arc>
3750
3751 bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
3752 image
3753
3754 box() - L<Imager::Draw/box>
3755
3756 circle() - L<Imager::Draw/circle>
3757
3758 colorcount() - L<Imager::Draw/colorcount>
3759
3760 convert() - L<Imager::Transformations/"Color transformations"> -
3761 transform the color space
3762
3763 copy() - L<Imager::Transformations/copy>
3764
3765 crop() - L<Imager::Transformations/crop> - extract part of an image
3766
3767 def_guess_type() - L<Imager::Files/def_guess_type>
3768
3769 deltag() -  L<Imager::ImageTypes/deltag> - delete image tags
3770
3771 difference() - L<Imager::Filters/"Image Difference">
3772
3773 errstr() - L<"Basic Overview">
3774
3775 filter() - L<Imager::Filters>
3776
3777 findcolor() - L<Imager::ImageTypes/findcolor> - search the image palette, if it
3778 has one
3779
3780 flip() - L<Imager::Transformations/flip>
3781
3782 flood_fill() - L<Imager::Draw/flood_fill>
3783
3784 getchannels() -  L<Imager::ImageTypes/getchannels>
3785
3786 getcolorcount() -  L<Imager::ImageTypes/getcolorcount>
3787
3788 getcolors() - L<Imager::ImageTypes/getcolors> - get colors from the image
3789 palette, if it has one
3790
3791 getcolorusage() - L<Imager::ImageTypes/getcolorusage>
3792
3793 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash>
3794
3795 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3796
3797 getheight() - L<Imager::ImageTypes/getwidth>
3798
3799 getmask() - L<Imager::ImageTypes/getmask>
3800
3801 getpixel() - L<Imager::Draw/getpixel>
3802
3803 getsamples() - L<Imager::Draw/getsamples>
3804
3805 getscanline() - L<Imager::Draw/getscanline>
3806
3807 getwidth() - L<Imager::ImageTypes/getwidth>
3808
3809 img_set() - L<Imager::ImageTypes/img_set>
3810
3811 init() - L<Imager::ImageTypes/init>
3812
3813 line() - L<Imager::Draw/line>
3814
3815 load_plugin() - L<Imager::Filters/load_plugin>
3816
3817 map() - L<Imager::Transformations/"Color Mappings"> - remap color
3818 channel values
3819
3820 masked() -  L<Imager::ImageTypes/masked> - make a masked image
3821
3822 matrix_transform() - L<Imager::Engines/matrix_transform>
3823
3824 maxcolors() - L<Imager::ImageTypes/maxcolors>
3825
3826 NC() - L<Imager::Handy/NC>
3827
3828 new() - L<Imager::ImageTypes/new>
3829
3830 newcolor() - L<Imager::Handy/newcolor>
3831
3832 newcolour() - L<Imager::Handy/newcolour>
3833
3834 newfont() - L<Imager::Handy/newfont>
3835
3836 NF() - L<Imager::Handy/NF>
3837
3838 open() - L<Imager::Files> - an alias for read()
3839
3840 parseiptc() - L<Imager::Files/parseiptc> - parse IPTC data from a JPEG
3841 image
3842
3843 paste() - L<Imager::Transformations/paste> - draw an image onto an image
3844
3845 polygon() - L<Imager::Draw/polygon>
3846
3847 polyline() - L<Imager::Draw/polyline>
3848
3849 read() - L<Imager::Files> - read a single image from an image file
3850
3851 read_multi() - L<Imager::Files> - read multiple images from an image
3852 file
3853
3854 register_filter() - L<Imager::Filters/register_filter>
3855
3856 register_reader() - L<Imager::Filters/register_reader>
3857
3858 register_writer() - L<Imager::Filters/register_writer>
3859
3860 rotate() - L<Imager::Transformations/rotate>
3861
3862 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
3863 image and use the alpha channel
3864
3865 scale() - L<Imager::Transformations/scale>
3866
3867 scaleX() - L<Imager::Transformations/scaleX>
3868
3869 scaleY() - L<Imager::Transformations/scaleY>
3870
3871 setcolors() - L<Imager::ImageTypes/setcolors> - set palette colors in
3872 a paletted image
3873
3874 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3875
3876 setmask() - L<Imager::ImageTypes/setmask>
3877
3878 setpixel() - L<Imager::Draw/setpixel>
3879
3880 setscanline() - L<Imager::Draw/setscanline>
3881
3882 settag() - L<Imager::ImageTypes/settag>
3883
3884 string() - L<Imager::Draw/string> - draw text on an image
3885
3886 tags() -  L<Imager::ImageTypes/tags> - fetch image tags
3887
3888 to_paletted() -  L<Imager::ImageTypes/to_paletted>
3889
3890 to_rgb16() - L<Imager::ImageTypes/to_rgb16>
3891
3892 to_rgb8() - L<Imager::ImageTypes/to_rgb8>
3893
3894 transform() - L<Imager::Engines/"transform">
3895
3896 transform2() - L<Imager::Engines/"transform2">
3897
3898 type() -  L<Imager::ImageTypes/type> - type of image (direct vs paletted)
3899
3900 unload_plugin() - L<Imager::Filters/unload_plugin>
3901
3902 virtual() - L<Imager::ImageTypes/virtual> - whether the image has it's own
3903 data
3904
3905 write() - L<Imager::Files> - write an image to a file
3906
3907 write_multi() - L<Imager::Files> - write multiple image to an image
3908 file.
3909
3910 =head1 CONCEPT INDEX
3911
3912 animated GIF - L<Imager::File/"Writing an animated GIF">
3913
3914 aspect ratio - L<Imager::ImageTypes/i_xres>,
3915 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
3916
3917 blend - alpha blending one image onto another
3918 L<Imager::Transformations/rubthrough>
3919
3920 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
3921
3922 boxes, drawing - L<Imager::Draw/box>
3923
3924 changes between image - L<Imager::Filter/"Image Difference">
3925
3926 color - L<Imager::Color>
3927
3928 color names - L<Imager::Color>, L<Imager::Color::Table>
3929
3930 combine modes - L<Imager::Fill/combine>
3931
3932 compare images - L<Imager::Filter/"Image Difference">
3933
3934 contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
3935
3936 convolution - L<Imager::Filter/conv>
3937
3938 cropping - L<Imager::Transformations/crop>
3939
3940 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
3941
3942 C<diff> images - L<Imager::Filter/"Image Difference">
3943
3944 dpi - L<Imager::ImageTypes/i_xres>,
3945 L<Imager::Cookbook/"Image spatial resolution">
3946
3947 drawing boxes - L<Imager::Draw/box>
3948
3949 drawing lines - L<Imager::Draw/line>
3950
3951 drawing text - L<Imager::Draw/string>, L<Imager::Draw/align_string>
3952
3953 error message - L<"Basic Overview">
3954
3955 files, font - L<Imager::Font>
3956
3957 files, image - L<Imager::Files>
3958
3959 filling, types of fill - L<Imager::Fill>
3960
3961 filling, boxes - L<Imager::Draw/box>
3962
3963 filling, flood fill - L<Imager::Draw/flood_fill>
3964
3965 flood fill - L<Imager::Draw/flood_fill>
3966
3967 fonts - L<Imager::Font>
3968
3969 fonts, drawing with - L<Imager::Draw/string>,
3970 L<Imager::Draw/align_string>, L<Imager::Font::Wrap>
3971
3972 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3973
3974 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
3975
3976 fountain fill - L<Imager::Fill/"Fountain fills">,
3977 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3978 L<Imager::Filters/gradgen>
3979
3980 GIF files - L<Imager::Files/"GIF">
3981
3982 GIF files, animated - L<Imager::File/"Writing an animated GIF">
3983
3984 gradient fill - L<Imager::Fill/"Fountain fills">,
3985 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3986 L<Imager::Filters/gradgen>
3987
3988 guassian blur - L<Imager::Filter/guassian>
3989
3990 hatch fills - L<Imager::Fill/"Hatched fills">
3991
3992 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
3993
3994 invert image - L<Imager::Filter/hardinvert>
3995
3996 JPEG - L<Imager::Files/"JPEG">
3997
3998 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
3999
4000 lines, drawing - L<Imager::Draw/line>
4001
4002 matrix - L<Imager::Matrix2d>,
4003 L<Imager::Transformations/"Matrix Transformations">,
4004 L<Imager::Font/transform>
4005
4006 metadata, image - L<Imager::ImageTypes/"Tags">
4007
4008 mosaic - L<Imager::Filter/mosaic>
4009
4010 noise, filter - L<Imager::Filter/noise>
4011
4012 noise, rendered - L<Imager::Filter/turbnoise>,
4013 L<Imager::Filter/radnoise>
4014
4015 paste - L<Imager::Transformations/paste>,
4016 L<Imager::Transformations/rubthrough>
4017
4018 pseudo-color image - L<Imager::ImageTypes/to_paletted>,
4019 L<Imager::ImageTypes/new>
4020
4021 posterize - L<Imager::Filter/postlevels>
4022
4023 png files - L<Imager::Files>, L<Imager::Files/"PNG">
4024
4025 pnm - L<Imager::Files/"PNM (Portable aNy Map)">
4026
4027 rectangles, drawing - L<Imager::Draw/box>
4028
4029 resizing an image - L<Imager::Transformations/scale>,
4030 L<Imager::Transformations/crop>
4031
4032 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4033
4034 saving an image - L<Imager::Files>
4035
4036 scaling - L<Imager::Transformations/scale>
4037
4038 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4039
4040 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4041
4042 size, image - L<Imager::ImageTypes/getwidth>,
4043 L<Imager::ImageTypes/getheight>
4044
4045 size, text - L<Imager::Font/bounding_box>
4046
4047 tags, image metadata - L<Imager::ImageTypes/"Tags">
4048
4049 text, drawing - L<Imager::Draw/string>, L<Imager::Draw/align_string>,
4050 L<Imager::Font::Wrap>
4051
4052 text, wrapping text in an area - L<Imager::Font::Wrap>
4053
4054 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4055
4056 tiles, color - L<Imager::Filter/mosaic>
4057
4058 unsharp mask - L<Imager::Filter/unsharpmask>
4059
4060 watermark - L<Imager::Filter/watermark>
4061
4062 writing an image to a file - L<Imager::Files>
4063
4064 =head1 SUPPORT
4065
4066 The best place to get help with Imager is the mailing list.
4067
4068 To subscribe send a message with C<subscribe> in the body to:
4069
4070    imager-devel+request@molar.is
4071
4072 or use the form at:
4073
4074 =over
4075
4076 L<http://www.molar.is/en/lists/imager-devel/>
4077
4078 =back
4079
4080 where you can also find the mailing list archive.
4081
4082 You can report bugs by pointing your browser at:
4083
4084 =over
4085
4086 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4087
4088 =back
4089
4090 Please remember to include the versions of Imager, perl, supporting
4091 libraries, and any relevant code.  If you have specific images that
4092 cause the problems, please include those too.
4093
4094 If you don't want to publish your email address on a mailing list you
4095 can use CPAN::Forum:
4096
4097   http://www.cpanforum.com/dist/Imager
4098
4099 You will need to register to post.
4100
4101 =head1 CONTRIBUTING TO IMAGER
4102
4103 =head2 Feedback
4104
4105 I like feedback.
4106
4107 If you like or dislike Imager, you can add a public review of Imager
4108 at CPAN Ratings:
4109
4110   http://cpanratings.perl.org/dist/Imager
4111
4112 This requires a Bitcard Account (http://www.bitcard.org).
4113
4114 You can also send email to the maintainer below.
4115
4116 If you send me a bug report via email, it will be copied to RT.
4117
4118 =head2 Patches
4119
4120 I accept patches, preferably against the main branch in subversion.
4121 You should include an explanation of the reason for why the patch is
4122 needed or useful.
4123
4124 Your patch should include regression tests where possible, otherwise
4125 it will be delayed until I get a chance to write them.
4126
4127 =head1 AUTHOR
4128
4129 Tony Cook <tony@imager.perl.org> is the current maintainer for Imager.
4130
4131 Arnar M. Hrafnkelsson is the original author of Imager.
4132
4133 Many others have contributed to Imager, please see the README for a
4134 complete list.
4135
4136 =head1 SEE ALSO
4137
4138 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4139 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4140 L<Imager::Font>(3), L<Imager::Transformations>(3),
4141 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4142 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4143
4144 L<http://imager.perl.org/>
4145
4146 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4147
4148 Other perl imaging modules include:
4149
4150 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3).
4151
4152 =cut