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 # draw string to an image
3273
3274 sub string {
3275   my $self = shift;
3276   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3277
3278   my %input=('x'=>0, 'y'=>0, @_);
3279   defined($input{string}) or $input{string} = $input{text};
3280
3281   unless(defined $input{string}) {
3282     $self->{ERRSTR}="missing required parameter 'string'";
3283     return;
3284   }
3285
3286   unless($input{font}) {
3287     $self->{ERRSTR}="missing required parameter 'font'";
3288     return;
3289   }
3290
3291   unless ($input{font}->draw(image=>$self, %input)) {
3292     return;
3293   }
3294
3295   return $self;
3296 }
3297
3298 sub align_string {
3299   my $self = shift;
3300
3301   my $img;
3302   if (ref $self) {
3303     unless ($self->{IMG}) {
3304       $self->{ERRSTR}='empty input image';
3305       return;
3306     }
3307     $img = $self;
3308   }
3309   else {
3310     $img = undef;
3311   }
3312
3313   my %input=('x'=>0, 'y'=>0, @_);
3314   $input{string}||=$input{text};
3315
3316   unless(exists $input{string}) {
3317     $self->_set_error("missing required parameter 'string'");
3318     return;
3319   }
3320
3321   unless($input{font}) {
3322     $self->_set_error("missing required parameter 'font'");
3323     return;
3324   }
3325
3326   my @result;
3327   unless (@result = $input{font}->align(image=>$img, %input)) {
3328     return;
3329   }
3330
3331   return wantarray ? @result : $result[0];
3332 }
3333
3334 my @file_limit_names = qw/width height bytes/;
3335
3336 sub set_file_limits {
3337   shift;
3338
3339   my %opts = @_;
3340   my %values;
3341
3342   if ($opts{reset}) {
3343     @values{@file_limit_names} = (0) x @file_limit_names;
3344   }
3345   else {
3346     @values{@file_limit_names} = i_get_image_file_limits();
3347   }
3348
3349   for my $key (keys %values) {
3350     defined $opts{$key} and $values{$key} = $opts{$key};
3351   }
3352
3353   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3354 }
3355
3356 sub get_file_limits {
3357   i_get_image_file_limits();
3358 }
3359
3360 # Shortcuts that can be exported
3361
3362 sub newcolor { Imager::Color->new(@_); }
3363 sub newfont  { Imager::Font->new(@_); }
3364
3365 *NC=*newcolour=*newcolor;
3366 *NF=*newfont;
3367
3368 *open=\&read;
3369 *circle=\&arc;
3370
3371
3372 #### Utility routines
3373
3374 sub errstr {
3375   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3376 }
3377
3378 sub _set_error {
3379   my ($self, $msg) = @_;
3380
3381   if (ref $self) {
3382     $self->{ERRSTR} = $msg;
3383   }
3384   else {
3385     $ERRSTR = $msg;
3386   }
3387   return;
3388 }
3389
3390 # Default guess for the type of an image from extension
3391
3392 sub def_guess_type {
3393   my $name=lc(shift);
3394   my $ext;
3395   $ext=($name =~ m/\.([^\.]+)$/)[0];
3396   return 'tiff' if ($ext =~ m/^tiff?$/);
3397   return 'jpeg' if ($ext =~ m/^jpe?g$/);
3398   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
3399   return 'png'  if ($ext eq "png");
3400   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
3401   return 'tga'  if ($ext eq "tga");
3402   return 'sgi'  if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
3403   return 'gif'  if ($ext eq "gif");
3404   return 'raw'  if ($ext eq "raw");
3405   return lc $ext; # best guess
3406   return ();
3407 }
3408
3409 # get the minimum of a list
3410
3411 sub _min {
3412   my $mx=shift;
3413   for(@_) { if ($_<$mx) { $mx=$_; }}
3414   return $mx;
3415 }
3416
3417 # get the maximum of a list
3418
3419 sub _max {
3420   my $mx=shift;
3421   for(@_) { if ($_>$mx) { $mx=$_; }}
3422   return $mx;
3423 }
3424
3425 # string stuff for iptc headers
3426
3427 sub _clean {
3428   my($str)=$_[0];
3429   $str = substr($str,3);
3430   $str =~ s/[\n\r]//g;
3431   $str =~ s/\s+/ /g;
3432   $str =~ s/^\s//;
3433   $str =~ s/\s$//;
3434   return $str;
3435 }
3436
3437 # A little hack to parse iptc headers.
3438
3439 sub parseiptc {
3440   my $self=shift;
3441   my(@sar,$item,@ar);
3442   my($caption,$photogr,$headln,$credit);
3443
3444   my $str=$self->{IPTCRAW};
3445
3446   defined $str
3447     or return;
3448
3449   @ar=split(/8BIM/,$str);
3450
3451   my $i=0;
3452   foreach (@ar) {
3453     if (/^\004\004/) {
3454       @sar=split(/\034\002/);
3455       foreach $item (@sar) {
3456         if ($item =~ m/^x/) {
3457           $caption = _clean($item);
3458           $i++;
3459         }
3460         if ($item =~ m/^P/) {
3461           $photogr = _clean($item);
3462           $i++;
3463         }
3464         if ($item =~ m/^i/) {
3465           $headln = _clean($item);
3466           $i++;
3467         }
3468         if ($item =~ m/^n/) {
3469           $credit = _clean($item);
3470           $i++;
3471         }
3472       }
3473     }
3474   }
3475   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3476 }
3477
3478 sub Inline {
3479   my ($lang) = @_;
3480
3481   $lang eq 'C'
3482     or die "Only C language supported";
3483
3484   require Imager::ExtUtils;
3485   return Imager::ExtUtils->inline_config;
3486 }
3487
3488 1;
3489 __END__
3490 # Below is the stub of documentation for your module. You better edit it!
3491
3492 =head1 NAME
3493
3494 Imager - Perl extension for Generating 24 bit Images
3495
3496 =head1 SYNOPSIS
3497
3498   # Thumbnail example
3499
3500   #!/usr/bin/perl -w
3501   use strict;
3502   use Imager;
3503
3504   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3505   my $file = shift;
3506
3507   my $format;
3508
3509   my $img = Imager->new();
3510   # see Imager::Files for information on the read() method
3511   $img->read(file=>$file) or die $img->errstr();
3512
3513   $file =~ s/\.[^.]*$//;
3514
3515   # Create smaller version
3516   # documented in Imager::Transformations
3517   my $thumb = $img->scale(scalefactor=>.3);
3518
3519   # Autostretch individual channels
3520   $thumb->filter(type=>'autolevels');
3521
3522   # try to save in one of these formats
3523   SAVE:
3524
3525   for $format ( qw( png gif jpg tiff ppm ) ) {
3526     # Check if given format is supported
3527     if ($Imager::formats{$format}) {
3528       $file.="_low.$format";
3529       print "Storing image as: $file\n";
3530       # documented in Imager::Files
3531       $thumb->write(file=>$file) or
3532         die $thumb->errstr;
3533       last SAVE;
3534     }
3535   }
3536
3537 =head1 DESCRIPTION
3538
3539 Imager is a module for creating and altering images.  It can read and
3540 write various image formats, draw primitive shapes like lines,and
3541 polygons, blend multiple images together in various ways, scale, crop,
3542 render text and more.
3543
3544 =head2 Overview of documentation
3545
3546 =over
3547
3548 =item *
3549
3550 Imager - This document - Synopsis, Example, Table of Contents and
3551 Overview.
3552
3553 =item *
3554
3555 L<Imager::Tutorial> - a brief introduction to Imager.
3556
3557 =item *
3558
3559 L<Imager::Cookbook> - how to do various things with Imager.
3560
3561 =item *
3562
3563 L<Imager::ImageTypes> - Basics of constructing image objects with
3564 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
3565 8/16/double bits/channel, color maps, channel masks, image tags, color
3566 quantization.  Also discusses basic image information methods.
3567
3568 =item *
3569
3570 L<Imager::Files> - IO interaction, reading/writing images, format
3571 specific tags.
3572
3573 =item *
3574
3575 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
3576 flood fill.
3577
3578 =item *
3579
3580 L<Imager::Color> - Color specification.
3581
3582 =item *
3583
3584 L<Imager::Fill> - Fill pattern specification.
3585
3586 =item *
3587
3588 L<Imager::Font> - General font rendering, bounding boxes and font
3589 metrics.
3590
3591 =item *
3592
3593 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
3594 blending, pasting, convert and map.
3595
3596 =item *
3597
3598 L<Imager::Engines> - Programmable transformations through
3599 C<transform()>, C<transform2()> and C<matrix_transform()>.
3600
3601 =item *
3602
3603 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
3604 filter plugins.
3605
3606 =item *
3607
3608 L<Imager::Expr> - Expressions for evaluation engine used by
3609 transform2().
3610
3611 =item *
3612
3613 L<Imager::Matrix2d> - Helper class for affine transformations.
3614
3615 =item *
3616
3617 L<Imager::Fountain> - Helper for making gradient profiles.
3618
3619 =item *
3620
3621 L<Imager::API> - using Imager's C API
3622
3623 =item *
3624
3625 L<Imager::APIRef> - API function reference
3626
3627 =item *
3628
3629 L<Imager::Inline> - using Imager's C API from Inline::C
3630
3631 =item *
3632
3633 L<Imager::ExtUtils> - tools to get access to Imager's C API.
3634
3635 =back
3636
3637 =head2 Basic Overview
3638
3639 An Image object is created with C<$img = Imager-E<gt>new()>.
3640 Examples:
3641
3642   $img=Imager->new();                         # create empty image
3643   $img->read(file=>'lena.png',type=>'png') or # read image from file
3644      die $img->errstr();                      # give an explanation
3645                                               # if something failed
3646
3647 or if you want to create an empty image:
3648
3649   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3650
3651 This example creates a completely black image of width 400 and height
3652 300 and 4 channels.
3653
3654 =head1 ERROR HANDLING
3655
3656 In general a method will return false when it fails, if it does use the errstr() method to find out why:
3657
3658 =over
3659
3660 =item errstr
3661
3662 Returns the last error message in that context.
3663
3664 If the last error you received was from calling an object method, such
3665 as read, call errstr() as an object method to find out why:
3666
3667   my $image = Imager->new;
3668   $image->read(file => 'somefile.gif')
3669      or die $image->errstr;
3670
3671 If it was a class method then call errstr() as a class method:
3672
3673   my @imgs = Imager->read_multi(file => 'somefile.gif')
3674     or die Imager->errstr;
3675
3676 Note that in some cases object methods are implemented in terms of
3677 class methods so a failing object method may set both.
3678
3679 =back
3680
3681 The C<Imager-E<gt>new> method is described in detail in
3682 L<Imager::ImageTypes>.
3683
3684 =head1 METHOD INDEX
3685
3686 Where to find information on methods for Imager class objects.
3687
3688 addcolors() -  L<Imager::ImageTypes/addcolors>
3689
3690 addtag() -  L<Imager::ImageTypes/addtag> - add image tags
3691
3692 align_string() - L<Imager::Draw/align_string>
3693
3694 arc() - L<Imager::Draw/arc>
3695
3696 bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
3697 image
3698
3699 box() - L<Imager::Draw/box>
3700
3701 circle() - L<Imager::Draw/circle>
3702
3703 colorcount() - L<Imager::Draw/colorcount>
3704
3705 convert() - L<Imager::Transformations/"Color transformations"> -
3706 transform the color space
3707
3708 copy() - L<Imager::Transformations/copy>
3709
3710 crop() - L<Imager::Transformations/crop> - extract part of an image
3711
3712 def_guess_type() - L<Imager::Files/def_guess_type>
3713
3714 deltag() -  L<Imager::ImageTypes/deltag> - delete image tags
3715
3716 difference() - L<Imager::Filters/"Image Difference">
3717
3718 errstr() - L<"Basic Overview">
3719
3720 filter() - L<Imager::Filters>
3721
3722 findcolor() - L<Imager::ImageTypes/findcolor> - search the image palette, if it
3723 has one
3724
3725 flip() - L<Imager::Transformations/flip>
3726
3727 flood_fill() - L<Imager::Draw/flood_fill>
3728
3729 getchannels() -  L<Imager::ImageTypes/getchannels>
3730
3731 getcolorcount() -  L<Imager::ImageTypes/getcolorcount>
3732
3733 getcolors() - L<Imager::ImageTypes/getcolors> - get colors from the image
3734 palette, if it has one
3735
3736 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3737
3738 getheight() - L<Imager::ImageTypes/getwidth>
3739
3740 getmask() - L<Imager::ImageTypes/getmask>
3741
3742 getpixel() - L<Imager::Draw/getpixel>
3743
3744 getsamples() - L<Imager::Draw/getsamples>
3745
3746 getscanline() - L<Imager::Draw/getscanline>
3747
3748 getwidth() - L<Imager::ImageTypes/getwidth>
3749
3750 img_set() - L<Imager::ImageTypes/img_set>
3751
3752 init() - L<Imager::ImageTypes/init>
3753
3754 line() - L<Imager::Draw/line>
3755
3756 load_plugin() - L<Imager::Filters/load_plugin>
3757
3758 map() - L<Imager::Transformations/"Color Mappings"> - remap color
3759 channel values
3760
3761 masked() -  L<Imager::ImageTypes/masked> - make a masked image
3762
3763 matrix_transform() - L<Imager::Engines/matrix_transform>
3764
3765 maxcolors() - L<Imager::ImageTypes/maxcolors>
3766
3767 NC() - L<Imager::Handy/NC>
3768
3769 new() - L<Imager::ImageTypes/new>
3770
3771 newcolor() - L<Imager::Handy/newcolor>
3772
3773 newcolour() - L<Imager::Handy/newcolour>
3774
3775 newfont() - L<Imager::Handy/newfont>
3776
3777 NF() - L<Imager::Handy/NF>
3778
3779 open() - L<Imager::Files> - an alias for read()
3780
3781 parseiptc() - L<Imager::Files/parseiptc> - parse IPTC data from a JPEG
3782 image
3783
3784 paste() - L<Imager::Transformations/paste> - draw an image onto an image
3785
3786 polygon() - L<Imager::Draw/polygon>
3787
3788 polyline() - L<Imager::Draw/polyline>
3789
3790 read() - L<Imager::Files> - read a single image from an image file
3791
3792 read_multi() - L<Imager::Files> - read multiple images from an image
3793 file
3794
3795 register_filter() - L<Imager::Filters/register_filter>
3796
3797 register_reader() - L<Imager::Filters/register_reader>
3798
3799 register_writer() - L<Imager::Filters/register_writer>
3800
3801 rotate() - L<Imager::Transformations/rotate>
3802
3803 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
3804 image and use the alpha channel
3805
3806 scale() - L<Imager::Transformations/scale>
3807
3808 scaleX() - L<Imager::Transformations/scaleX>
3809
3810 scaleY() - L<Imager::Transformations/scaleY>
3811
3812 setcolors() - L<Imager::ImageTypes/setcolors> - set palette colors in
3813 a paletted image
3814
3815 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3816
3817 setmask() - L<Imager::ImageTypes/setmask>
3818
3819 setpixel() - L<Imager::Draw/setpixel>
3820
3821 setscanline() - L<Imager::Draw/setscanline>
3822
3823 settag() - L<Imager::ImageTypes/settag>
3824
3825 string() - L<Imager::Draw/string> - draw text on an image
3826
3827 tags() -  L<Imager::ImageTypes/tags> - fetch image tags
3828
3829 to_paletted() -  L<Imager::ImageTypes/to_paletted>
3830
3831 to_rgb16() - L<Imager::ImageTypes/to_rgb16>
3832
3833 to_rgb8() - L<Imager::ImageTypes/to_rgb8>
3834
3835 transform() - L<Imager::Engines/"transform">
3836
3837 transform2() - L<Imager::Engines/"transform2">
3838
3839 type() -  L<Imager::ImageTypes/type> - type of image (direct vs paletted)
3840
3841 unload_plugin() - L<Imager::Filters/unload_plugin>
3842
3843 virtual() - L<Imager::ImageTypes/virtual> - whether the image has it's own
3844 data
3845
3846 write() - L<Imager::Files> - write an image to a file
3847
3848 write_multi() - L<Imager::Files> - write multiple image to an image
3849 file.
3850
3851 =head1 CONCEPT INDEX
3852
3853 animated GIF - L<Imager::File/"Writing an animated GIF">
3854
3855 aspect ratio - L<Imager::ImageTypes/i_xres>,
3856 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
3857
3858 blend - alpha blending one image onto another
3859 L<Imager::Transformations/rubthrough>
3860
3861 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
3862
3863 boxes, drawing - L<Imager::Draw/box>
3864
3865 changes between image - L<Imager::Filter/"Image Difference">
3866
3867 color - L<Imager::Color>
3868
3869 color names - L<Imager::Color>, L<Imager::Color::Table>
3870
3871 combine modes - L<Imager::Fill/combine>
3872
3873 compare images - L<Imager::Filter/"Image Difference">
3874
3875 contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
3876
3877 convolution - L<Imager::Filter/conv>
3878
3879 cropping - L<Imager::Transformations/crop>
3880
3881 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
3882
3883 C<diff> images - L<Imager::Filter/"Image Difference">
3884
3885 dpi - L<Imager::ImageTypes/i_xres>,
3886 L<Imager::Cookbook/"Image spatial resolution">
3887
3888 drawing boxes - L<Imager::Draw/box>
3889
3890 drawing lines - L<Imager::Draw/line>
3891
3892 drawing text - L<Imager::Draw/string>, L<Imager::Draw/align_string>
3893
3894 error message - L<"Basic Overview">
3895
3896 files, font - L<Imager::Font>
3897
3898 files, image - L<Imager::Files>
3899
3900 filling, types of fill - L<Imager::Fill>
3901
3902 filling, boxes - L<Imager::Draw/box>
3903
3904 filling, flood fill - L<Imager::Draw/flood_fill>
3905
3906 flood fill - L<Imager::Draw/flood_fill>
3907
3908 fonts - L<Imager::Font>
3909
3910 fonts, drawing with - L<Imager::Draw/string>,
3911 L<Imager::Draw/align_string>, L<Imager::Font::Wrap>
3912
3913 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3914
3915 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
3916
3917 fountain fill - L<Imager::Fill/"Fountain fills">,
3918 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3919 L<Imager::Filters/gradgen>
3920
3921 GIF files - L<Imager::Files/"GIF">
3922
3923 GIF files, animated - L<Imager::File/"Writing an animated GIF">
3924
3925 gradient fill - L<Imager::Fill/"Fountain fills">,
3926 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3927 L<Imager::Filters/gradgen>
3928
3929 guassian blur - L<Imager::Filter/guassian>
3930
3931 hatch fills - L<Imager::Fill/"Hatched fills">
3932
3933 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
3934
3935 invert image - L<Imager::Filter/hardinvert>
3936
3937 JPEG - L<Imager::Files/"JPEG">
3938
3939 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
3940
3941 lines, drawing - L<Imager::Draw/line>
3942
3943 matrix - L<Imager::Matrix2d>,
3944 L<Imager::Transformations/"Matrix Transformations">,
3945 L<Imager::Font/transform>
3946
3947 metadata, image - L<Imager::ImageTypes/"Tags">
3948
3949 mosaic - L<Imager::Filter/mosaic>
3950
3951 noise, filter - L<Imager::Filter/noise>
3952
3953 noise, rendered - L<Imager::Filter/turbnoise>,
3954 L<Imager::Filter/radnoise>
3955
3956 paste - L<Imager::Transformations/paste>,
3957 L<Imager::Transformations/rubthrough>
3958
3959 pseudo-color image - L<Imager::ImageTypes/to_paletted>,
3960 L<Imager::ImageTypes/new>
3961
3962 posterize - L<Imager::Filter/postlevels>
3963
3964 png files - L<Imager::Files>, L<Imager::Files/"PNG">
3965
3966 pnm - L<Imager::Files/"PNM (Portable aNy Map)">
3967
3968 rectangles, drawing - L<Imager::Draw/box>
3969
3970 resizing an image - L<Imager::Transformations/scale>,
3971 L<Imager::Transformations/crop>
3972
3973 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
3974
3975 saving an image - L<Imager::Files>
3976
3977 scaling - L<Imager::Transformations/scale>
3978
3979 SGI files - L<Imager::Files/"SGI (RGB, BW)">
3980
3981 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
3982
3983 size, image - L<Imager::ImageTypes/getwidth>,
3984 L<Imager::ImageTypes/getheight>
3985
3986 size, text - L<Imager::Font/bounding_box>
3987
3988 tags, image metadata - L<Imager::ImageTypes/"Tags">
3989
3990 text, drawing - L<Imager::Draw/string>, L<Imager::Draw/align_string>,
3991 L<Imager::Font::Wrap>
3992
3993 text, wrapping text in an area - L<Imager::Font::Wrap>
3994
3995 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3996
3997 tiles, color - L<Imager::Filter/mosaic>
3998
3999 unsharp mask - L<Imager::Filter/unsharpmask>
4000
4001 watermark - L<Imager::Filter/watermark>
4002
4003 writing an image to a file - L<Imager::Files>
4004
4005 =head1 SUPPORT
4006
4007 The best place to get help with Imager is the mailing list.
4008
4009 To subscribe send a message with C<subscribe> in the body to:
4010
4011    imager-devel+request@molar.is
4012
4013 or use the form at:
4014
4015 =over
4016
4017 L<http://www.molar.is/en/lists/imager-devel/>
4018
4019 =back
4020
4021 where you can also find the mailing list archive.
4022
4023 You can report bugs by pointing your browser at:
4024
4025 =over
4026
4027 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4028
4029 =back
4030
4031 Please remember to include the versions of Imager, perl, supporting
4032 libraries, and any relevant code.  If you have specific images that
4033 cause the problems, please include those too.
4034
4035 If you don't want to publish your email address on a mailing list you
4036 can use CPAN::Forum:
4037
4038   http://www.cpanforum.com/dist/Imager
4039
4040 You will need to register to post.
4041
4042 =head1 CONTRIBUTING TO IMAGER
4043
4044 =head2 Feedback
4045
4046 I like feedback.
4047
4048 If you like or dislike Imager, you can add a public review of Imager
4049 at CPAN Ratings:
4050
4051   http://cpanratings.perl.org/dist/Imager
4052
4053 This requires a Bitcard Account (http://www.bitcard.org).
4054
4055 You can also send email to the maintainer below.
4056
4057 If you send me a bug report via email, it will be copied to RT.
4058
4059 =head2 Patches
4060
4061 I accept patches, preferably against the main branch in subversion.
4062 You should include an explanation of the reason for why the patch is
4063 needed or useful.
4064
4065 Your patch should include regression tests where possible, otherwise
4066 it will be delayed until I get a chance to write them.
4067
4068 =head1 AUTHOR
4069
4070 Tony Cook <tony@imager.perl.org> is the current maintainer for Imager.
4071
4072 Arnar M. Hrafnkelsson is the original author of Imager.
4073
4074 Many others have contributed to Imager, please see the README for a
4075 complete list.
4076
4077 =head1 SEE ALSO
4078
4079 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4080 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4081 L<Imager::Font>(3), L<Imager::Transformations>(3),
4082 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4083 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4084
4085 L<http://imager.perl.org/>
4086
4087 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4088
4089 Other perl imaging modules include:
4090
4091 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3).
4092
4093 =cut