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.53';
 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
 758   my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
 759
 760   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
 761   return $dst;
 762 }
 763
 764 sub _sametype {
 765   my ($self, %opts) = @_;
 766
 767   $self->{IMG} or return $self->_set_error("Not a valid image");
 768
 769   my $x = $opts{xsize} || $self->getwidth;
 770   my $y = $opts{ysize} || $self->getheight;
 771   my $channels = $opts{channels} || $self->getchannels;
 772
 773   my $out = Imager->new;
 774   if ($channels == $self->getchannels) {
 775     $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
 776   }
 777   else {
 778     $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
 779   }
 780   unless ($out->{IMG}) {
 781     $self->{ERRSTR} = $self->_error_as_msg;
 782     return;
 783   }
 784
 785   return $out;
 786 }
 787
 788 # Sets an image to a certain size and channel number
 789 # if there was previously data in the image it is discarded
 790
 791 sub img_set {
 792   my $self=shift;
 793
 794   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
 795
 796   if (defined($self->{IMG})) {
 797     # let IIM_DESTROY destroy it, it's possible this image is
 798     # referenced from a virtual image (like masked)
 799     #i_img_destroy($self->{IMG});
 800     undef($self->{IMG});
 801   }
 802
 803   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
 804     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
 805                                  $hsh{maxcolors} || 256);
 806   }
 807   elsif ($hsh{bits} eq 'double') {
 808     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 809   }
 810   elsif ($hsh{bits} == 16) {
 811     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 812   }
 813   else {
 814     $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
 815                                      $hsh{'channels'});
 816   }
 817
 818   unless ($self->{IMG}) {
 819     $self->{ERRSTR} = Imager->_error_as_msg();
 820     return;
 821   }
 822
 823   $self;
 824 }
 825
 826 # created a masked version of the current image
 827 sub masked {
 828   my $self = shift;
 829
 830   $self or return undef;
 831   my %opts = (left    => 0,
 832               top     => 0,
 833               right   => $self->getwidth,
 834               bottom  => $self->getheight,
 835               @_);
 836   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
 837
 838   my $result = Imager->new;
 839   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
 840                                     $opts{top}, $opts{right} - $opts{left},
 841                                     $opts{bottom} - $opts{top});
 842   # keep references to the mask and base images so they don't
 843   # disappear on us
 844   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
 845
 846   $result;
 847 }
 848
 849 # convert an RGB image into a paletted image
 850 sub to_paletted {
 851   my $self = shift;
 852   my $opts;
 853   if (@_ != 1 && !ref $_[0]) {
 854     $opts = { @_ };
 855   }
 856   else {
 857     $opts = shift;
 858   }
 859
 860   unless (defined wantarray) {
 861     my @caller = caller;
 862     warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
 863     return;
 864   }
 865
 866   my $result = Imager->new;
 867   $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
 868
 869   #print "Type ", i_img_type($result->{IMG}), "\n";
 870
 871   if ($result->{IMG}) {
 872     return $result;
 873   }
 874   else {
 875     $self->{ERRSTR} = $self->_error_as_msg;
 876     return;
 877   }
 878 }
 879
 880 # convert a paletted (or any image) to an 8-bit/channel RGB images
 881 sub to_rgb8 {
 882   my $self = shift;
 883   my $result;
 884
 885   unless (defined wantarray) {
 886     my @caller = caller;
 887     warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
 888     return;
 889   }
 890
 891   if ($self->{IMG}) {
 892     $result = Imager->new;
 893     $result->{IMG} = i_img_to_rgb($self->{IMG})
 894       or undef $result;
 895   }
 896
 897   return $result;
 898 }
 899
 900 sub addcolors {
 901   my $self = shift;
 902   my %opts = (colors=>[], @_);
 903
 904   unless ($self->{IMG}) {
 905     $self->_set_error("empty input image");
 906     return;
 907   }
 908
 909   my @colors = @{$opts{colors}}
 910     or return undef;
 911
 912   for my $color (@colors) {
 913     $color = _color($color);
 914     unless ($color) {
 915       $self->_set_error($Imager::ERRSTR);
 916       return;
 917     }
 918   }
 919
 920   return i_addcolors($self->{IMG}, @colors);
 921 }
 922
 923 sub setcolors {
 924   my $self = shift;
 925   my %opts = (start=>0, 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_setcolors($self->{IMG}, $opts{start}, @colors);
 944 }
 945
 946 sub getcolors {
 947   my $self = shift;
 948   my %opts = @_;
 949   if (!exists $opts{start} && !exists $opts{count}) {
 950     # get them all
 951     $opts{start} = 0;
 952     $opts{count} = $self->colorcount;
 953   }
 954   elsif (!exists $opts{count}) {
 955     $opts{count} = 1;
 956   }
 957   elsif (!exists $opts{start}) {
 958     $opts{start} = 0;
 959   }
 960
 961   $self->{IMG} and
 962     return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
 963 }
 964
 965 sub colorcount {
 966   i_colorcount($_[0]{IMG});
 967 }
 968
 969 sub maxcolors {
 970   i_maxcolors($_[0]{IMG});
 971 }
 972
 973 sub findcolor {
 974   my $self = shift;
 975   my %opts = @_;
 976   $opts{color} or return undef;
 977
 978   $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
 979 }
 980
 981 sub bits {
 982   my $self = shift;
 983   my $bits = $self->{IMG} && i_img_bits($self->{IMG});
 984   if ($bits && $bits == length(pack("d", 1)) * 8) {
 985     $bits = 'double';
 986   }
 987   $bits;
 988 }
 989
 990 sub type {
 991   my $self = shift;
 992   if ($self->{IMG}) {
 993     return i_img_type($self->{IMG}) ? "paletted" : "direct";
 994   }
 995 }
 996
 997 sub virtual {
 998   my $self = shift;
 999   $self->{IMG} and i_img_virtual($self->{IMG});
1000 }
1001
1002 sub tags {
1003   my ($self, %opts) = @_;
1004
1005   $self->{IMG} or return;
1006
1007   if (defined $opts{name}) {
1008     my @result;
1009     my $start = 0;
1010     my $found;
1011     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1012       push @result, (i_tags_get($self->{IMG}, $found))[1];
1013       $start = $found+1;
1014     }
1015     return wantarray ? @result : $result[0];
1016   }
1017   elsif (defined $opts{code}) {
1018     my @result;
1019     my $start = 0;
1020     my $found;
1021     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1022       push @result, (i_tags_get($self->{IMG}, $found))[1];
1023       $start = $found+1;
1024     }
1025     return @result;
1026   }
1027   else {
1028     if (wantarray) {
1029       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1030     }
1031     else {
1032       return i_tags_count($self->{IMG});
1033     }
1034   }
1035 }
1036
1037 sub addtag {
1038   my $self = shift;
1039   my %opts = @_;
1040
1041   return -1 unless $self->{IMG};
1042   if ($opts{name}) {
1043     if (defined $opts{value}) {
1044       if ($opts{value} =~ /^\d+$/) {
1045         # add as a number
1046         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1047       }
1048       else {
1049         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1050       }
1051     }
1052     elsif (defined $opts{data}) {
1053       # force addition as a string
1054       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1055     }
1056     else {
1057       $self->{ERRSTR} = "No value supplied";
1058       return undef;
1059     }
1060   }
1061   elsif ($opts{code}) {
1062     if (defined $opts{value}) {
1063       if ($opts{value} =~ /^\d+$/) {
1064         # add as a number
1065         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1066       }
1067       else {
1068         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1069       }
1070     }
1071     elsif (defined $opts{data}) {
1072       # force addition as a string
1073       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1074     }
1075     else {
1076       $self->{ERRSTR} = "No value supplied";
1077       return undef;
1078     }
1079   }
1080   else {
1081     return undef;
1082   }
1083 }
1084
1085 sub deltag {
1086   my $self = shift;
1087   my %opts = @_;
1088
1089   return 0 unless $self->{IMG};
1090
1091   if (defined $opts{'index'}) {
1092     return i_tags_delete($self->{IMG}, $opts{'index'});
1093   }
1094   elsif (defined $opts{name}) {
1095     return i_tags_delbyname($self->{IMG}, $opts{name});
1096   }
1097   elsif (defined $opts{code}) {
1098     return i_tags_delbycode($self->{IMG}, $opts{code});
1099   }
1100   else {
1101     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1102     return 0;
1103   }
1104 }
1105
1106 sub settag {
1107   my ($self, %opts) = @_;
1108
1109   if ($opts{name}) {
1110     $self->deltag(name=>$opts{name});
1111     return $self->addtag(name=>$opts{name}, value=>$opts{value});
1112   }
1113   elsif (defined $opts{code}) {
1114     $self->deltag(code=>$opts{code});
1115     return $self->addtag(code=>$opts{code}, value=>$opts{value});
1116   }
1117   else {
1118     return undef;
1119   }
1120 }
1121
1122
1123 sub _get_reader_io {
1124   my ($self, $input) = @_;
1125
1126   if ($input->{io}) {
1127     return $input->{io}, undef;
1128   }
1129   elsif ($input->{fd}) {
1130     return io_new_fd($input->{fd});
1131   }
1132   elsif ($input->{fh}) {
1133     my $fd = fileno($input->{fh});
1134     unless ($fd) {
1135       $self->_set_error("Handle in fh option not opened");
1136       return;
1137     }
1138     return io_new_fd($fd);
1139   }
1140   elsif ($input->{file}) {
1141     my $file = IO::File->new($input->{file}, "r");
1142     unless ($file) {
1143       $self->_set_error("Could not open $input->{file}: $!");
1144       return;
1145     }
1146     binmode $file;
1147     return (io_new_fd(fileno($file)), $file);
1148   }
1149   elsif ($input->{data}) {
1150     return io_new_buffer($input->{data});
1151   }
1152   elsif ($input->{callback} || $input->{readcb}) {
1153     if (!$input->{seekcb}) {
1154       $self->_set_error("Need a seekcb parameter");
1155     }
1156     if ($input->{maxbuffer}) {
1157       return io_new_cb($input->{writecb},
1158                        $input->{callback} || $input->{readcb},
1159                        $input->{seekcb}, $input->{closecb},
1160                        $input->{maxbuffer});
1161     }
1162     else {
1163       return io_new_cb($input->{writecb},
1164                        $input->{callback} || $input->{readcb},
1165                        $input->{seekcb}, $input->{closecb});
1166     }
1167   }
1168   else {
1169     $self->_set_error("file/fd/fh/data/callback parameter missing");
1170     return;
1171   }
1172 }
1173
1174 sub _get_writer_io {
1175   my ($self, $input, $type) = @_;
1176
1177   if ($input->{io}) {
1178     return $input->{io};
1179   }
1180   elsif ($input->{fd}) {
1181     return io_new_fd($input->{fd});
1182   }
1183   elsif ($input->{fh}) {
1184     my $fd = fileno($input->{fh});
1185     unless ($fd) {
1186       $self->_set_error("Handle in fh option not opened");
1187       return;
1188     }
1189     # flush it
1190     my $oldfh = select($input->{fh});
1191     # flush anything that's buffered, and make sure anything else is flushed
1192     $| = 1;
1193     select($oldfh);
1194     return io_new_fd($fd);
1195   }
1196   elsif ($input->{file}) {
1197     my $fh = new IO::File($input->{file},"w+");
1198     unless ($fh) {
1199       $self->_set_error("Could not open file $input->{file}: $!");
1200       return;
1201     }
1202     binmode($fh) or die;
1203     return (io_new_fd(fileno($fh)), $fh);
1204   }
1205   elsif ($input->{data}) {
1206     return io_new_bufchain();
1207   }
1208   elsif ($input->{callback} || $input->{writecb}) {
1209     if ($input->{maxbuffer}) {
1210       return io_new_cb($input->{callback} || $input->{writecb},
1211                        $input->{readcb},
1212                        $input->{seekcb}, $input->{closecb},
1213                        $input->{maxbuffer});
1214     }
1215     else {
1216       return io_new_cb($input->{callback} || $input->{writecb},
1217                        $input->{readcb},
1218                        $input->{seekcb}, $input->{closecb});
1219     }
1220   }
1221   else {
1222     $self->_set_error("file/fd/fh/data/callback parameter missing");
1223     return;
1224   }
1225 }
1226
1227 # Read an image from file
1228
1229 sub read {
1230   my $self = shift;
1231   my %input=@_;
1232
1233   if (defined($self->{IMG})) {
1234     # let IIM_DESTROY do the destruction, since the image may be
1235     # referenced from elsewhere
1236     #i_img_destroy($self->{IMG});
1237     undef($self->{IMG});
1238   }
1239
1240   my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1241
1242   unless ($input{'type'}) {
1243     $input{'type'} = i_test_format_probe($IO, -1);
1244   }
1245
1246   unless ($input{'type'}) {
1247           $self->_set_error('type parameter missing and not possible to guess from extension');
1248     return undef;
1249   }
1250
1251   _reader_autoload($input{type});
1252
1253   if ($readers{$input{type}} && $readers{$input{type}}{single}) {
1254     return $readers{$input{type}}{single}->($self, $IO, %input);
1255   }
1256
1257   unless ($formats{$input{'type'}}) {
1258     $self->_set_error("format '$input{'type'}' not supported");
1259     return;
1260   }
1261
1262   # Setup data source
1263   if ( $input{'type'} eq 'jpeg' ) {
1264     ($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
1265     if ( !defined($self->{IMG}) ) {
1266       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1267     }
1268     $self->{DEBUG} && print "loading a jpeg file\n";
1269     return $self;
1270   }
1271
1272   if ( $input{'type'} eq 'tiff' ) {
1273     my $page = $input{'page'};
1274     defined $page or $page = 0;
1275     # Fixme, check if that length parameter is ever needed
1276     $self->{IMG}=i_readtiff_wiol( $IO, -1, $page );
1277     if ( !defined($self->{IMG}) ) {
1278       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1279     }
1280     $self->{DEBUG} && print "loading a tiff file\n";
1281     return $self;
1282   }
1283
1284   if ( $input{'type'} eq 'pnm' ) {
1285     $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1286     if ( !defined($self->{IMG}) ) {
1287       $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1288       return undef;
1289     }
1290     $self->{DEBUG} && print "loading a pnm file\n";
1291     return $self;
1292   }
1293
1294   if ( $input{'type'} eq 'png' ) {
1295     $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1296     if ( !defined($self->{IMG}) ) {
1297       $self->{ERRSTR} = $self->_error_as_msg();
1298       return undef;
1299     }
1300     $self->{DEBUG} && print "loading a png file\n";
1301   }
1302
1303   if ( $input{'type'} eq 'bmp' ) {
1304     $self->{IMG}=i_readbmp_wiol( $IO );
1305     if ( !defined($self->{IMG}) ) {
1306       $self->{ERRSTR}=$self->_error_as_msg();
1307       return undef;
1308     }
1309     $self->{DEBUG} && print "loading a bmp file\n";
1310   }
1311
1312   if ( $input{'type'} eq 'gif' ) {
1313     if ($input{colors} && !ref($input{colors})) {
1314       # must be a reference to a scalar that accepts the colour map
1315       $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1316       return undef;
1317     }
1318     if ($input{'gif_consolidate'}) {
1319       if ($input{colors}) {
1320         my $colors;
1321         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1322         if ($colors) {
1323           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1324         }
1325       }
1326       else {
1327         $self->{IMG} =i_readgif_wiol( $IO );
1328       }
1329     }
1330     else {
1331       my $page = $input{'page'};
1332       defined $page or $page = 0;
1333       $self->{IMG} = i_readgif_single_wiol( $IO, $page );
1334       if ($input{colors}) {
1335         ${ $input{colors} } =
1336           [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ];
1337       }
1338     }
1339
1340     if ( !defined($self->{IMG}) ) {
1341       $self->{ERRSTR}=$self->_error_as_msg();
1342       return undef;
1343     }
1344     $self->{DEBUG} && print "loading a gif file\n";
1345   }
1346
1347   if ( $input{'type'} eq 'tga' ) {
1348     $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1349     if ( !defined($self->{IMG}) ) {
1350       $self->{ERRSTR}=$self->_error_as_msg();
1351       return undef;
1352     }
1353     $self->{DEBUG} && print "loading a tga file\n";
1354   }
1355
1356   if ( $input{'type'} eq 'rgb' ) {
1357     $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1358     if ( !defined($self->{IMG}) ) {
1359       $self->{ERRSTR}=$self->_error_as_msg();
1360       return undef;
1361     }
1362     $self->{DEBUG} && print "loading a tga file\n";
1363   }
1364
1365
1366   if ( $input{'type'} eq 'raw' ) {
1367     my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1368
1369     if ( !($params{xsize} && $params{ysize}) ) {
1370       $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1371       return undef;
1372     }
1373
1374     $self->{IMG} = i_readraw_wiol( $IO,
1375                                    $params{xsize},
1376                                    $params{ysize},
1377                                    $params{datachannels},
1378                                    $params{storechannels},
1379                                    $params{interleave});
1380     if ( !defined($self->{IMG}) ) {
1381       $self->{ERRSTR}=$self->_error_as_msg();
1382       return undef;
1383     }
1384     $self->{DEBUG} && print "loading a raw file\n";
1385   }
1386
1387   return $self;
1388 }
1389
1390 sub register_reader {
1391   my ($class, %opts) = @_;
1392
1393   defined $opts{type}
1394     or die "register_reader called with no type parameter\n";
1395
1396   my $type = $opts{type};
1397
1398   defined $opts{single} || defined $opts{multiple}
1399     or die "register_reader called with no single or multiple parameter\n";
1400
1401   $readers{$type} = {  };
1402   if ($opts{single}) {
1403     $readers{$type}{single} = $opts{single};
1404   }
1405   if ($opts{multiple}) {
1406     $readers{$type}{multiple} = $opts{multiple};
1407   }
1408
1409   return 1;
1410 }
1411
1412 sub register_writer {
1413   my ($class, %opts) = @_;
1414
1415   defined $opts{type}
1416     or die "register_writer called with no type parameter\n";
1417
1418   my $type = $opts{type};
1419
1420   defined $opts{single} || defined $opts{multiple}
1421     or die "register_writer called with no single or multiple parameter\n";
1422
1423   $writers{$type} = {  };
1424   if ($opts{single}) {
1425     $writers{$type}{single} = $opts{single};
1426   }
1427   if ($opts{multiple}) {
1428     $writers{$type}{multiple} = $opts{multiple};
1429   }
1430
1431   return 1;
1432 }
1433
1434 # probes for an Imager::File::whatever module
1435 sub _reader_autoload {
1436   my $type = shift;
1437
1438   return if $formats{$type} || $readers{$type};
1439
1440   return unless $type =~ /^\w+$/;
1441
1442   my $file = "Imager/File/\U$type\E.pm";
1443
1444   unless ($attempted_to_load{$file}) {
1445     eval {
1446       ++$attempted_to_load{$file};
1447       require $file;
1448     };
1449     if ($@) {
1450       # try to get a reader specific module
1451       my $file = "Imager/File/\U$type\EReader.pm";
1452       unless ($attempted_to_load{$file}) {
1453         eval {
1454           ++$attempted_to_load{$file};
1455           require $file;
1456         };
1457       }
1458     }
1459   }
1460 }
1461
1462 # probes for an Imager::File::whatever module
1463 sub _writer_autoload {
1464   my $type = shift;
1465
1466   return if $formats{$type} || $readers{$type};
1467
1468   return unless $type =~ /^\w+$/;
1469
1470   my $file = "Imager/File/\U$type\E.pm";
1471
1472   unless ($attempted_to_load{$file}) {
1473     eval {
1474       ++$attempted_to_load{$file};
1475       require $file;
1476     };
1477     if ($@) {
1478       # try to get a writer specific module
1479       my $file = "Imager/File/\U$type\EWriter.pm";
1480       unless ($attempted_to_load{$file}) {
1481         eval {
1482           ++$attempted_to_load{$file};
1483           require $file;
1484         };
1485       }
1486     }
1487   }
1488 }
1489
1490 sub _fix_gif_positions {
1491   my ($opts, $opt, $msg, @imgs) = @_;
1492
1493   my $positions = $opts->{'gif_positions'};
1494   my $index = 0;
1495   for my $pos (@$positions) {
1496     my ($x, $y) = @$pos;
1497     my $img = $imgs[$index++];
1498     $img->settag(name=>'gif_left', value=>$x);
1499     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1500   }
1501   $$msg .= "replaced with the gif_left and gif_top tags";
1502 }
1503
1504 my %obsolete_opts =
1505   (
1506    gif_each_palette=>'gif_local_map',
1507    interlace       => 'gif_interlace',
1508    gif_delays => 'gif_delay',
1509    gif_positions => \&_fix_gif_positions,
1510    gif_loop_count => 'gif_loop',
1511   );
1512
1513 sub _set_opts {
1514   my ($self, $opts, $prefix, @imgs) = @_;
1515
1516   for my $opt (keys %$opts) {
1517     my $tagname = $opt;
1518     if ($obsolete_opts{$opt}) {
1519       my $new = $obsolete_opts{$opt};
1520       my $msg = "Obsolete option $opt ";
1521       if (ref $new) {
1522         $new->($opts, $opt, \$msg, @imgs);
1523       }
1524       else {
1525         $msg .= "replaced with the $new tag ";
1526         $tagname = $new;
1527       }
1528       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1529       warn $msg if $warn_obsolete && $^W;
1530     }
1531     next unless $tagname =~ /^\Q$prefix/;
1532     my $value = $opts->{$opt};
1533     if (ref $value) {
1534       if (UNIVERSAL::isa($value, "Imager::Color")) {
1535         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1536         for my $img (@imgs) {
1537           $img->settag(name=>$tagname, value=>$tag);
1538         }
1539       }
1540       elsif (ref($value) eq 'ARRAY') {
1541         for my $i (0..$#$value) {
1542           my $val = $value->[$i];
1543           if (ref $val) {
1544             if (UNIVERSAL::isa($val, "Imager::Color")) {
1545               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1546               $i < @imgs and
1547                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1548             }
1549             else {
1550               $self->_set_error("Unknown reference type " . ref($value) .
1551                                 " supplied in array for $opt");
1552               return;
1553             }
1554           }
1555           else {
1556             $i < @imgs
1557               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1558           }
1559         }
1560       }
1561       else {
1562         $self->_set_error("Unknown reference type " . ref($value) .
1563                           " supplied for $opt");
1564         return;
1565       }
1566     }
1567     else {
1568       # set it as a tag for every image
1569       for my $img (@imgs) {
1570         $img->settag(name=>$tagname, value=>$value);
1571       }
1572     }
1573   }
1574
1575   return 1;
1576 }
1577
1578 # Write an image to file
1579 sub write {
1580   my $self = shift;
1581   my %input=(jpegquality=>75,
1582              gifquant=>'mc',
1583              lmdither=>6.0,
1584              lmfixed=>[],
1585              idstring=>"",
1586              compress=>1,
1587              wierdpack=>0,
1588              fax_fine=>1, @_);
1589   my $rc;
1590
1591   $self->_set_opts(\%input, "i_", $self)
1592     or return undef;
1593
1594   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1595
1596   if (!$input{'type'} and $input{file}) {
1597     $input{'type'}=$FORMATGUESS->($input{file});
1598   }
1599   if (!$input{'type'}) {
1600     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1601     return undef;
1602   }
1603
1604   _writer_autoload($input{type});
1605
1606   my ($IO, $fh);
1607   if ($writers{$input{type}} && $writers{$input{type}}{single}) {
1608     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1609       or return undef;
1610
1611     $writers{$input{type}}{single}->($self, $IO, %input)
1612       or return undef;
1613   }
1614   else {
1615     if (!$formats{$input{'type'}}) {
1616       $self->{ERRSTR}='format not supported';
1617       return undef;
1618     }
1619
1620     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1621       or return undef;
1622
1623     if ($input{'type'} eq 'tiff') {
1624       $self->_set_opts(\%input, "tiff_", $self)
1625         or return undef;
1626       $self->_set_opts(\%input, "exif_", $self)
1627         or return undef;
1628
1629       if (defined $input{class} && $input{class} eq 'fax') {
1630         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1631           $self->{ERRSTR} = $self->_error_as_msg();
1632           return undef;
1633         }
1634       } else {
1635         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1636           $self->{ERRSTR} = $self->_error_as_msg();
1637           return undef;
1638         }
1639       }
1640     } elsif ( $input{'type'} eq 'pnm' ) {
1641       $self->_set_opts(\%input, "pnm_", $self)
1642         or return undef;
1643       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1644         $self->{ERRSTR} = $self->_error_as_msg();
1645         return undef;
1646       }
1647       $self->{DEBUG} && print "writing a pnm file\n";
1648     } elsif ( $input{'type'} eq 'raw' ) {
1649       $self->_set_opts(\%input, "raw_", $self)
1650         or return undef;
1651       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1652         $self->{ERRSTR} = $self->_error_as_msg();
1653         return undef;
1654       }
1655       $self->{DEBUG} && print "writing a raw file\n";
1656     } elsif ( $input{'type'} eq 'png' ) {
1657       $self->_set_opts(\%input, "png_", $self)
1658         or return undef;
1659       if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1660         $self->{ERRSTR}='unable to write png image';
1661         return undef;
1662       }
1663       $self->{DEBUG} && print "writing a png file\n";
1664     } elsif ( $input{'type'} eq 'jpeg' ) {
1665       $self->_set_opts(\%input, "jpeg_", $self)
1666         or return undef;
1667       $self->_set_opts(\%input, "exif_", $self)
1668         or return undef;
1669       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1670         $self->{ERRSTR} = $self->_error_as_msg();
1671         return undef;
1672       }
1673       $self->{DEBUG} && print "writing a jpeg file\n";
1674     } elsif ( $input{'type'} eq 'bmp' ) {
1675       $self->_set_opts(\%input, "bmp_", $self)
1676         or return undef;
1677       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1678         $self->{ERRSTR}='unable to write bmp image';
1679         return undef;
1680       }
1681       $self->{DEBUG} && print "writing a bmp file\n";
1682     } elsif ( $input{'type'} eq 'tga' ) {
1683       $self->_set_opts(\%input, "tga_", $self)
1684         or return undef;
1685
1686       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1687         $self->{ERRSTR}=$self->_error_as_msg();
1688         return undef;
1689       }
1690       $self->{DEBUG} && print "writing a tga file\n";
1691     } elsif ( $input{'type'} eq 'gif' ) {
1692       $self->_set_opts(\%input, "gif_", $self)
1693         or return undef;
1694       # compatibility with the old interfaces
1695       if ($input{gifquant} eq 'lm') {
1696         $input{make_colors} = 'addi';
1697         $input{translate} = 'perturb';
1698         $input{perturb} = $input{lmdither};
1699       } elsif ($input{gifquant} eq 'gen') {
1700         # just pass options through
1701       } else {
1702         $input{make_colors} = 'webmap'; # ignored
1703         $input{translate} = 'giflib';
1704       }
1705       if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1706         $self->{ERRSTR} = $self->_error_as_msg;
1707         return;
1708       }
1709     }
1710   }
1711
1712   if (exists $input{'data'}) {
1713     my $data = io_slurp($IO);
1714     if (!$data) {
1715       $self->{ERRSTR}='Could not slurp from buffer';
1716       return undef;
1717     }
1718     ${$input{data}} = $data;
1719   }
1720   return $self;
1721 }
1722
1723 sub write_multi {
1724   my ($class, $opts, @images) = @_;
1725
1726   my $type = $opts->{type};
1727
1728   if (!$type && $opts->{'file'}) {
1729     $type = $FORMATGUESS->($opts->{'file'});
1730   }
1731   unless ($type) {
1732     $class->_set_error('type parameter missing and not possible to guess from extension');
1733     return;
1734   }
1735   # translate to ImgRaw
1736   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1737     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1738     return 0;
1739   }
1740   $class->_set_opts($opts, "i_", @images)
1741     or return;
1742   my @work = map $_->{IMG}, @images;
1743
1744   _writer_autoload($type);
1745
1746   my ($IO, $file);
1747   if ($writers{$type} && $writers{$type}{multiple}) {
1748     ($IO, $file) = $class->_get_writer_io($opts, $type)
1749       or return undef;
1750
1751     $writers{$type}{multiple}->($class, $IO, $opts, @images)
1752       or return undef;
1753   }
1754   else {
1755     if (!$formats{$type}) {
1756       $class->_set_error("format $type not supported");
1757       return undef;
1758     }
1759
1760     ($IO, $file) = $class->_get_writer_io($opts, $type)
1761       or return undef;
1762
1763     if ($type eq 'gif') {
1764       $class->_set_opts($opts, "gif_", @images)
1765         or return;
1766       my $gif_delays = $opts->{gif_delays};
1767       local $opts->{gif_delays} = $gif_delays;
1768       if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1769         # assume the caller wants the same delay for each frame
1770         $opts->{gif_delays} = [ ($gif_delays) x @images ];
1771       }
1772       unless (i_writegif_wiol($IO, $opts, @work)) {
1773         $class->_set_error($class->_error_as_msg());
1774         return undef;
1775       }
1776     }
1777     elsif ($type eq 'tiff') {
1778       $class->_set_opts($opts, "tiff_", @images)
1779         or return;
1780       $class->_set_opts($opts, "exif_", @images)
1781         or return;
1782       my $res;
1783       $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1784       if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1785         $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1786       }
1787       else {
1788         $res = i_writetiff_multi_wiol($IO, @work);
1789       }
1790       unless ($res) {
1791         $class->_set_error($class->_error_as_msg());
1792         return undef;
1793       }
1794     }
1795     else {
1796       if (@images == 1) {
1797         unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1798           return 1;
1799         }
1800       }
1801       else {
1802         $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1803         return 0;
1804       }
1805     }
1806   }
1807
1808   if (exists $opts->{'data'}) {
1809     my $data = io_slurp($IO);
1810     if (!$data) {
1811       Imager->_set_error('Could not slurp from buffer');
1812       return undef;
1813     }
1814     ${$opts->{data}} = $data;
1815   }
1816   return 1;
1817 }
1818
1819 # read multiple images from a file
1820 sub read_multi {
1821   my ($class, %opts) = @_;
1822
1823   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1824     or return;
1825
1826   my $type = $opts{'type'};
1827   unless ($type) {
1828     $type = i_test_format_probe($IO, -1);
1829   }
1830
1831   if ($opts{file} && !$type) {
1832     # guess the type
1833     $type = $FORMATGUESS->($opts{file});
1834   }
1835
1836   unless ($type) {
1837     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1838     return;
1839   }
1840
1841   _reader_autoload($type);
1842
1843   if ($readers{$type} && $readers{$type}{multiple}) {
1844     return $readers{$type}{multiple}->($IO, %opts);
1845   }
1846
1847   if ($type eq 'gif') {
1848     my @imgs;
1849     @imgs = i_readgif_multi_wiol($IO);
1850     if (@imgs) {
1851       return map {
1852         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1853       } @imgs;
1854     }
1855     else {
1856       $ERRSTR = _error_as_msg();
1857       return;
1858     }
1859   }
1860   elsif ($type eq 'tiff') {
1861     my @imgs = i_readtiff_multi_wiol($IO, -1);
1862     if (@imgs) {
1863       return map {
1864         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1865       } @imgs;
1866     }
1867     else {
1868       $ERRSTR = _error_as_msg();
1869       return;
1870     }
1871   }
1872   else {
1873     my $img = Imager->new;
1874     if ($img->read(%opts, io => $IO, type => $type)) {
1875       return ( $img );
1876     }
1877   }
1878
1879   $ERRSTR = "Cannot read multiple images from $type files";
1880   return;
1881 }
1882
1883 # Destroy an Imager object
1884
1885 sub DESTROY {
1886   my $self=shift;
1887   #    delete $instances{$self};
1888   if (defined($self->{IMG})) {
1889     # the following is now handled by the XS DESTROY method for
1890     # Imager::ImgRaw object
1891     # Re-enabling this will break virtual images
1892     # tested for in t/t020masked.t
1893     # i_img_destroy($self->{IMG});
1894     undef($self->{IMG});
1895   } else {
1896 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1897   }
1898 }
1899
1900 # Perform an inplace filter of an image
1901 # that is the image will be overwritten with the data
1902
1903 sub filter {
1904   my $self=shift;
1905   my %input=@_;
1906   my %hsh;
1907   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1908
1909   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1910
1911   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1912     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1913   }
1914
1915   if ($filters{$input{'type'}}{names}) {
1916     my $names = $filters{$input{'type'}}{names};
1917     for my $name (keys %$names) {
1918       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1919         $input{$name} = $names->{$name}{$input{$name}};
1920       }
1921     }
1922   }
1923   if (defined($filters{$input{'type'}}{defaults})) {
1924     %hsh=( image => $self->{IMG},
1925            imager => $self,
1926            %{$filters{$input{'type'}}{defaults}},
1927            %input );
1928   } else {
1929     %hsh=( image => $self->{IMG},
1930            imager => $self,
1931            %input );
1932   }
1933
1934   my @cs=@{$filters{$input{'type'}}{callseq}};
1935
1936   for(@cs) {
1937     if (!defined($hsh{$_})) {
1938       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1939     }
1940   }
1941
1942   eval {
1943     local $SIG{__DIE__}; # we don't want this processed by confess, etc
1944     &{$filters{$input{'type'}}{callsub}}(%hsh);
1945   };
1946   if ($@) {
1947     chomp($self->{ERRSTR} = $@);
1948     return;
1949   }
1950
1951   my @b=keys %hsh;
1952
1953   $self->{DEBUG} && print "callseq is: @cs\n";
1954   $self->{DEBUG} && print "matching callseq is: @b\n";
1955
1956   return $self;
1957 }
1958
1959 sub register_filter {
1960   my $class = shift;
1961   my %hsh = ( defaults => {}, @_ );
1962
1963   defined $hsh{type}
1964     or die "register_filter() with no type\n";
1965   defined $hsh{callsub}
1966     or die "register_filter() with no callsub\n";
1967   defined $hsh{callseq}
1968     or die "register_filter() with no callseq\n";
1969
1970   exists $filters{$hsh{type}}
1971     and return;
1972
1973   $filters{$hsh{type}} = \%hsh;
1974
1975   return 1;
1976 }
1977
1978 # Scale an image to requested size and return the scaled version
1979
1980 sub scale {
1981   my $self=shift;
1982   my %opts=('type'=>'max',qtype=>'normal',@_);
1983   my $img = Imager->new();
1984   my $tmp = Imager->new();
1985   my ($x_scale, $y_scale);
1986
1987   unless (defined wantarray) {
1988     my @caller = caller;
1989     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
1990     return;
1991   }
1992
1993   unless ($self->{IMG}) {
1994     $self->_set_error('empty input image');
1995     return undef;
1996   }
1997
1998   if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
1999     $x_scale = $opts{'xscalefactor'};
2000     $y_scale = $opts{'yscalefactor'};
2001   }
2002   elsif ($opts{'xscalefactor'}) {
2003     $x_scale = $opts{'xscalefactor'};
2004     $y_scale = $opts{'scalefactor'} || $x_scale;
2005   }
2006   elsif ($opts{'yscalefactor'}) {
2007     $y_scale = $opts{'yscalefactor'};
2008     $x_scale = $opts{'scalefactor'} || $y_scale;
2009   }
2010   else {
2011     $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2012   }
2013
2014   # work out the scaling
2015   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
2016     my ($xpix, $ypix)=( $opts{xpixels} / $self->getwidth() ,
2017                         $opts{ypixels} / $self->getheight() );
2018     if ($opts{'type'} eq 'min') {
2019       $x_scale = $y_scale = _min($xpix,$ypix);
2020     }
2021     elsif ($opts{'type'} eq 'max') {
2022       $x_scale = $y_scale = _max($xpix,$ypix);
2023     }
2024     elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2025       $x_scale = $xpix;
2026       $y_scale = $ypix;
2027     }
2028     else {
2029       $self->_set_error('invalid value for type parameter');
2030       return undef;
2031     }
2032   } elsif ($opts{xpixels}) {
2033     $x_scale = $y_scale = $opts{xpixels} / $self->getwidth();
2034   }
2035   elsif ($opts{ypixels}) {
2036     $x_scale = $y_scale = $opts{ypixels}/$self->getheight();
2037   }
2038   elsif ($opts{constrain} && ref $opts{constrain}
2039          && $opts{constrain}->can('constrain')) {
2040     # we've been passed an Image::Math::Constrain object or something
2041     # that looks like one
2042     my $scalefactor;
2043     (undef, undef, $scalefactor)
2044       = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2045     unless ($scalefactor) {
2046       $self->_set_error('constrain method failed on constrain parameter');
2047       return undef;
2048     }
2049     $x_scale = $y_scale = $scalefactor;
2050   }
2051
2052   if ($opts{qtype} eq 'normal') {
2053     $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2054     if ( !defined($tmp->{IMG}) ) {
2055       $self->{ERRSTR} = 'unable to scale image';
2056       return undef;
2057     }
2058     $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2059     if ( !defined($img->{IMG}) ) {
2060       $self->{ERRSTR}='unable to scale image';
2061       return undef;
2062     }
2063
2064     return $img;
2065   }
2066   elsif ($opts{'qtype'} eq 'preview') {
2067     $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
2068     if ( !defined($img->{IMG}) ) {
2069       $self->{ERRSTR}='unable to scale image';
2070       return undef;
2071     }
2072     return $img;
2073   }
2074   elsif ($opts{'qtype'} eq 'mixing') {
2075     my $new_width = int(0.5 + $self->getwidth * $x_scale);
2076     my $new_height = int(0.5 + $self->getheight * $y_scale);
2077     $new_width >= 1 or $new_width = 1;
2078     $new_height >= 1 or $new_height = 1;
2079     $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2080     unless ($img->{IMG}) {
2081       $self->_set_error(Imager->_error_as_meg);
2082       return;
2083     }
2084     return $img;
2085   }
2086   else {
2087     $self->_set_error('invalid value for qtype parameter');
2088     return undef;
2089   }
2090 }
2091
2092 # Scales only along the X axis
2093
2094 sub scaleX {
2095   my $self = shift;
2096   my %opts = ( scalefactor=>0.5, @_ );
2097
2098   unless (defined wantarray) {
2099     my @caller = caller;
2100     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2101     return;
2102   }
2103
2104   unless ($self->{IMG}) {
2105     $self->{ERRSTR} = 'empty input image';
2106     return undef;
2107   }
2108
2109   my $img = Imager->new();
2110
2111   my $scalefactor = $opts{scalefactor};
2112
2113   if ($opts{pixels}) {
2114     $scalefactor = $opts{pixels} / $self->getwidth();
2115   }
2116
2117   unless ($self->{IMG}) {
2118     $self->{ERRSTR}='empty input image';
2119     return undef;
2120   }
2121
2122   $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2123
2124   if ( !defined($img->{IMG}) ) {
2125     $self->{ERRSTR} = 'unable to scale image';
2126     return undef;
2127   }
2128
2129   return $img;
2130 }
2131
2132 # Scales only along the Y axis
2133
2134 sub scaleY {
2135   my $self = shift;
2136   my %opts = ( scalefactor => 0.5, @_ );
2137
2138   unless (defined wantarray) {
2139     my @caller = caller;
2140     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2141     return;
2142   }
2143
2144   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2145
2146   my $img = Imager->new();
2147
2148   my $scalefactor = $opts{scalefactor};
2149
2150   if ($opts{pixels}) {
2151     $scalefactor = $opts{pixels} / $self->getheight();
2152   }
2153
2154   unless ($self->{IMG}) {
2155     $self->{ERRSTR} = 'empty input image';
2156     return undef;
2157   }
2158   $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2159
2160   if ( !defined($img->{IMG}) ) {
2161     $self->{ERRSTR} = 'unable to scale image';
2162     return undef;
2163   }
2164
2165   return $img;
2166 }
2167
2168 # Transform returns a spatial transformation of the input image
2169 # this moves pixels to a new location in the returned image.
2170 # NOTE - should make a utility function to check transforms for
2171 # stack overruns
2172
2173 sub transform {
2174   my $self=shift;
2175   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2176   my %opts=@_;
2177   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2178
2179 #  print Dumper(\%opts);
2180 #  xopcopdes
2181
2182   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2183     if (!$I2P) {
2184       eval ("use Affix::Infix2Postfix;");
2185       print $@;
2186       if ( $@ ) {
2187         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2188         return undef;
2189       }
2190       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2191                                              {op=>'-',trans=>'Sub'},
2192                                              {op=>'*',trans=>'Mult'},
2193                                              {op=>'/',trans=>'Div'},
2194                                              {op=>'-','type'=>'unary',trans=>'u-'},
2195                                              {op=>'**'},
2196                                              {op=>'func','type'=>'unary'}],
2197                                      'grouping'=>[qw( \( \) )],
2198                                      'func'=>[qw( sin cos )],
2199                                      'vars'=>[qw( x y )]
2200                                     );
2201     }
2202
2203     @xt=$I2P->translate($opts{'xexpr'});
2204     @yt=$I2P->translate($opts{'yexpr'});
2205
2206     $numre=$I2P->{'numre'};
2207     @pt=(0,0);
2208
2209     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2210     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2211     @{$opts{'parm'}}=@pt;
2212   }
2213
2214 #  print Dumper(\%opts);
2215
2216   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2217     $self->{ERRSTR}='transform: no xopcodes given.';
2218     return undef;
2219   }
2220
2221   @op=@{$opts{'xopcodes'}};
2222   for $iop (@op) {
2223     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2224       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2225       return undef;
2226     }
2227     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2228   }
2229
2230
2231 # yopcopdes
2232
2233   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2234     $self->{ERRSTR}='transform: no yopcodes given.';
2235     return undef;
2236   }
2237
2238   @op=@{$opts{'yopcodes'}};
2239   for $iop (@op) {
2240     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2241       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2242       return undef;
2243     }
2244     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2245   }
2246
2247 #parameters
2248
2249   if ( !exists $opts{'parm'}) {
2250     $self->{ERRSTR}='transform: no parameter arg given.';
2251     return undef;
2252   }
2253
2254 #  print Dumper(\@ropx);
2255 #  print Dumper(\@ropy);
2256 #  print Dumper(\@ropy);
2257
2258   my $img = Imager->new();
2259   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2260   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2261   return $img;
2262 }
2263
2264
2265 sub transform2 {
2266   my ($opts, @imgs) = @_;
2267
2268   require "Imager/Expr.pm";
2269
2270   $opts->{variables} = [ qw(x y) ];
2271   my ($width, $height) = @{$opts}{qw(width height)};
2272   if (@imgs) {
2273     $width ||= $imgs[0]->getwidth();
2274     $height ||= $imgs[0]->getheight();
2275     my $img_num = 1;
2276     for my $img (@imgs) {
2277       $opts->{constants}{"w$img_num"} = $img->getwidth();
2278       $opts->{constants}{"h$img_num"} = $img->getheight();
2279       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2280       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2281       ++$img_num;
2282     }
2283   }
2284   if ($width) {
2285     $opts->{constants}{w} = $width;
2286     $opts->{constants}{cx} = $width/2;
2287   }
2288   else {
2289     $Imager::ERRSTR = "No width supplied";
2290     return;
2291   }
2292   if ($height) {
2293     $opts->{constants}{h} = $height;
2294     $opts->{constants}{cy} = $height/2;
2295   }
2296   else {
2297     $Imager::ERRSTR = "No height supplied";
2298     return;
2299   }
2300   my $code = Imager::Expr->new($opts);
2301   if (!$code) {
2302     $Imager::ERRSTR = Imager::Expr::error();
2303     return;
2304   }
2305   my $channels = $opts->{channels} || 3;
2306   unless ($channels >= 1 && $channels <= 4) {
2307     return Imager->_set_error("channels must be an integer between 1 and 4");
2308   }
2309
2310   my $img = Imager->new();
2311   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2312                              $channels, $code->code(),
2313                              $code->nregs(), $code->cregs(),
2314                              [ map { $_->{IMG} } @imgs ]);
2315   if (!defined $img->{IMG}) {
2316     $Imager::ERRSTR = Imager->_error_as_msg();
2317     return;
2318   }
2319
2320   return $img;
2321 }
2322
2323 sub rubthrough {
2324   my $self=shift;
2325   my %opts=(tx => 0,ty => 0, @_);
2326
2327   unless ($self->{IMG}) {
2328     $self->{ERRSTR}='empty input image';
2329     return undef;
2330   }
2331   unless ($opts{src} && $opts{src}->{IMG}) {
2332     $self->{ERRSTR}='empty input image for src';
2333     return undef;
2334   }
2335
2336   %opts = (src_minx => 0,
2337            src_miny => 0,
2338            src_maxx => $opts{src}->getwidth(),
2339            src_maxy => $opts{src}->getheight(),
2340            %opts);
2341
2342   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx}, $opts{ty},
2343                     $opts{src_minx}, $opts{src_miny},
2344                     $opts{src_maxx}, $opts{src_maxy})) {
2345     $self->_set_error($self->_error_as_msg());
2346     return undef;
2347   }
2348   return $self;
2349 }
2350
2351
2352 sub flip {
2353   my $self  = shift;
2354   my %opts  = @_;
2355   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2356   my $dir;
2357   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2358   $dir = $xlate{$opts{'dir'}};
2359   return $self if i_flipxy($self->{IMG}, $dir);
2360   return ();
2361 }
2362
2363 sub rotate {
2364   my $self = shift;
2365   my %opts = @_;
2366
2367   unless (defined wantarray) {
2368     my @caller = caller;
2369     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2370     return;
2371   }
2372
2373   if (defined $opts{right}) {
2374     my $degrees = $opts{right};
2375     if ($degrees < 0) {
2376       $degrees += 360 * int(((-$degrees)+360)/360);
2377     }
2378     $degrees = $degrees % 360;
2379     if ($degrees == 0) {
2380       return $self->copy();
2381     }
2382     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2383       my $result = Imager->new();
2384       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2385         return $result;
2386       }
2387       else {
2388         $self->{ERRSTR} = $self->_error_as_msg();
2389         return undef;
2390       }
2391     }
2392     else {
2393       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2394       return undef;
2395     }
2396   }
2397   elsif (defined $opts{radians} || defined $opts{degrees}) {
2398     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2399
2400     my $back = $opts{back};
2401     my $result = Imager->new;
2402     if ($back) {
2403       $back = _color($back);
2404       unless ($back) {
2405         $self->_set_error(Imager->errstr);
2406         return undef;
2407       }
2408
2409       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2410     }
2411     else {
2412       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2413     }
2414     if ($result->{IMG}) {
2415       return $result;
2416     }
2417     else {
2418       $self->{ERRSTR} = $self->_error_as_msg();
2419       return undef;
2420     }
2421   }
2422   else {
2423     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2424     return undef;
2425   }
2426 }
2427
2428 sub matrix_transform {
2429   my $self = shift;
2430   my %opts = @_;
2431
2432   unless (defined wantarray) {
2433     my @caller = caller;
2434     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2435     return;
2436   }
2437
2438   if ($opts{matrix}) {
2439     my $xsize = $opts{xsize} || $self->getwidth;
2440     my $ysize = $opts{ysize} || $self->getheight;
2441
2442     my $result = Imager->new;
2443     if ($opts{back}) {
2444       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2445                                           $opts{matrix}, $opts{back})
2446         or return undef;
2447     }
2448     else {
2449       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2450                                           $opts{matrix})
2451         or return undef;
2452     }
2453
2454     return $result;
2455   }
2456   else {
2457     $self->{ERRSTR} = "matrix parameter required";
2458     return undef;
2459   }
2460 }
2461
2462 # blame Leolo :)
2463 *yatf = \&matrix_transform;
2464
2465 # These two are supported for legacy code only
2466
2467 sub i_color_new {
2468   return Imager::Color->new(@_);
2469 }
2470
2471 sub i_color_set {
2472   return Imager::Color::set(@_);
2473 }
2474
2475 # Draws a box between the specified corner points.
2476 sub box {
2477   my $self=shift;
2478   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2479   my $dflcl=i_color_new(255,255,255,255);
2480   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2481
2482   if (exists $opts{'box'}) {
2483     $opts{'xmin'} = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2484     $opts{'xmax'} = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2485     $opts{'ymin'} = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2486     $opts{'ymax'} = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2487   }
2488
2489   if ($opts{filled}) {
2490     my $color = _color($opts{'color'});
2491     unless ($color) {
2492       $self->{ERRSTR} = $Imager::ERRSTR;
2493       return;
2494     }
2495     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2496                  $opts{ymax}, $color);
2497   }
2498   elsif ($opts{fill}) {
2499     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2500       # assume it's a hash ref
2501       require 'Imager/Fill.pm';
2502       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2503         $self->{ERRSTR} = $Imager::ERRSTR;
2504         return undef;
2505       }
2506     }
2507     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2508                 $opts{ymax},$opts{fill}{fill});
2509   }
2510   else {
2511     my $color = _color($opts{'color'});
2512     unless ($color) {
2513       $self->{ERRSTR} = $Imager::ERRSTR;
2514       return;
2515     }
2516     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2517           $color);
2518   }
2519   return $self;
2520 }
2521
2522 sub arc {
2523   my $self=shift;
2524   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2525   my $dflcl=i_color_new(255,255,255,255);
2526   my %opts=(color=>$dflcl,
2527             'r'=>_min($self->getwidth(),$self->getheight())/3,
2528             'x'=>$self->getwidth()/2,
2529             'y'=>$self->getheight()/2,
2530             'd1'=>0, 'd2'=>361, @_);
2531   if ($opts{aa}) {
2532     if ($opts{fill}) {
2533       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2534         # assume it's a hash ref
2535         require 'Imager/Fill.pm';
2536         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2537           $self->{ERRSTR} = $Imager::ERRSTR;
2538           return;
2539         }
2540       }
2541       i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2542                      $opts{'d2'}, $opts{fill}{fill});
2543     }
2544     else {
2545       my $color = _color($opts{'color'});
2546       unless ($color) {
2547         $self->{ERRSTR} = $Imager::ERRSTR;
2548         return;
2549       }
2550       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2551         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2552                     $color);
2553       }
2554       else {
2555         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2556                  $opts{'d1'}, $opts{'d2'}, $color);
2557       }
2558     }
2559   }
2560   else {
2561     if ($opts{fill}) {
2562       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2563         # assume it's a hash ref
2564         require 'Imager/Fill.pm';
2565         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2566           $self->{ERRSTR} = $Imager::ERRSTR;
2567           return;
2568         }
2569       }
2570       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2571                   $opts{'d2'}, $opts{fill}{fill});
2572     }
2573     else {
2574       my $color = _color($opts{'color'});
2575       unless ($color) {
2576         $self->{ERRSTR} = $Imager::ERRSTR;
2577         return;
2578       }
2579       i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2580             $opts{'d1'}, $opts{'d2'}, $color);
2581     }
2582   }
2583
2584   return $self;
2585 }
2586
2587 # Draws a line from one point to the other
2588 # the endpoint is set if the endp parameter is set which it is by default.
2589 # to turn of the endpoint being set use endp=>0 when calling line.
2590
2591 sub line {
2592   my $self=shift;
2593   my $dflcl=i_color_new(0,0,0,0);
2594   my %opts=(color=>$dflcl,
2595             endp => 1,
2596             @_);
2597   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2598
2599   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2600   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2601
2602   my $color = _color($opts{'color'});
2603   unless ($color) {
2604     $self->{ERRSTR} = $Imager::ERRSTR;
2605     return;
2606   }
2607
2608   $opts{antialias} = $opts{aa} if defined $opts{aa};
2609   if ($opts{antialias}) {
2610     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2611               $color, $opts{endp});
2612   } else {
2613     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2614            $color, $opts{endp});
2615   }
2616   return $self;
2617 }
2618
2619 # Draws a line between an ordered set of points - It more or less just transforms this
2620 # into a list of lines.
2621
2622 sub polyline {
2623   my $self=shift;
2624   my ($pt,$ls,@points);
2625   my $dflcl=i_color_new(0,0,0,0);
2626   my %opts=(color=>$dflcl,@_);
2627
2628   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2629
2630   if (exists($opts{points})) { @points=@{$opts{points}}; }
2631   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2632     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2633     }
2634
2635 #  print Dumper(\@points);
2636
2637   my $color = _color($opts{'color'});
2638   unless ($color) {
2639     $self->{ERRSTR} = $Imager::ERRSTR;
2640     return;
2641   }
2642   $opts{antialias} = $opts{aa} if defined $opts{aa};
2643   if ($opts{antialias}) {
2644     for $pt(@points) {
2645       if (defined($ls)) {
2646         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2647       }
2648       $ls=$pt;
2649     }
2650   } else {
2651     for $pt(@points) {
2652       if (defined($ls)) {
2653         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2654       }
2655       $ls=$pt;
2656     }
2657   }
2658   return $self;
2659 }
2660
2661 sub polygon {
2662   my $self = shift;
2663   my ($pt,$ls,@points);
2664   my $dflcl = i_color_new(0,0,0,0);
2665   my %opts = (color=>$dflcl, @_);
2666
2667   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2668
2669   if (exists($opts{points})) {
2670     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2671     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2672   }
2673
2674   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2675     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2676   }
2677
2678   if ($opts{'fill'}) {
2679     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2680       # assume it's a hash ref
2681       require 'Imager/Fill.pm';
2682       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2683         $self->{ERRSTR} = $Imager::ERRSTR;
2684         return undef;
2685       }
2686     }
2687     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2688                     $opts{'fill'}{'fill'});
2689   }
2690   else {
2691     my $color = _color($opts{'color'});
2692     unless ($color) {
2693       $self->{ERRSTR} = $Imager::ERRSTR;
2694       return;
2695     }
2696     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2697   }
2698
2699   return $self;
2700 }
2701
2702
2703 # this the multipoint bezier curve
2704 # this is here more for testing that actual usage since
2705 # this is not a good algorithm.  Usually the curve would be
2706 # broken into smaller segments and each done individually.
2707
2708 sub polybezier {
2709   my $self=shift;
2710   my ($pt,$ls,@points);
2711   my $dflcl=i_color_new(0,0,0,0);
2712   my %opts=(color=>$dflcl,@_);
2713
2714   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2715
2716   if (exists $opts{points}) {
2717     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2718     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2719   }
2720
2721   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2722     $self->{ERRSTR}='Missing or invalid points.';
2723     return;
2724   }
2725
2726   my $color = _color($opts{'color'});
2727   unless ($color) {
2728     $self->{ERRSTR} = $Imager::ERRSTR;
2729     return;
2730   }
2731   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2732   return $self;
2733 }
2734
2735 sub flood_fill {
2736   my $self = shift;
2737   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2738   my $rc;
2739
2740   unless (exists $opts{'x'} && exists $opts{'y'}) {
2741     $self->{ERRSTR} = "missing seed x and y parameters";
2742     return undef;
2743   }
2744
2745   if ($opts{border}) {
2746     my $border = _color($opts{border});
2747     unless ($border) {
2748       $self->_set_error($Imager::ERRSTR);
2749       return;
2750     }
2751     if ($opts{fill}) {
2752       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2753         # assume it's a hash ref
2754         require Imager::Fill;
2755         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2756           $self->{ERRSTR} = $Imager::ERRSTR;
2757           return;
2758         }
2759       }
2760       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2761                                  $opts{fill}{fill}, $border);
2762     }
2763     else {
2764       my $color = _color($opts{'color'});
2765       unless ($color) {
2766         $self->{ERRSTR} = $Imager::ERRSTR;
2767         return;
2768       }
2769       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2770                                 $color, $border);
2771     }
2772     if ($rc) {
2773       return $self;
2774     }
2775     else {
2776       $self->{ERRSTR} = $self->_error_as_msg();
2777       return;
2778     }
2779   }
2780   else {
2781     if ($opts{fill}) {
2782       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2783         # assume it's a hash ref
2784         require 'Imager/Fill.pm';
2785         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2786           $self->{ERRSTR} = $Imager::ERRSTR;
2787           return;
2788         }
2789       }
2790       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2791     }
2792     else {
2793       my $color = _color($opts{'color'});
2794       unless ($color) {
2795         $self->{ERRSTR} = $Imager::ERRSTR;
2796         return;
2797       }
2798       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2799     }
2800     if ($rc) {
2801       return $self;
2802     }
2803     else {
2804       $self->{ERRSTR} = $self->_error_as_msg();
2805       return;
2806     }
2807   }
2808 }
2809
2810 sub setpixel {
2811   my $self = shift;
2812
2813   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2814
2815   unless (exists $opts{'x'} && exists $opts{'y'}) {
2816     $self->{ERRSTR} = 'missing x and y parameters';
2817     return undef;
2818   }
2819
2820   my $x = $opts{'x'};
2821   my $y = $opts{'y'};
2822   my $color = _color($opts{color})
2823     or return undef;
2824   if (ref $x && ref $y) {
2825     unless (@$x == @$y) {
2826       $self->{ERRSTR} = 'length of x and y mismatch';
2827       return undef;
2828     }
2829     if ($color->isa('Imager::Color')) {
2830       for my $i (0..$#{$opts{'x'}}) {
2831         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2832       }
2833     }
2834     else {
2835       for my $i (0..$#{$opts{'x'}}) {
2836         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2837       }
2838     }
2839   }
2840   else {
2841     if ($color->isa('Imager::Color')) {
2842       i_ppix($self->{IMG}, $x, $y, $color);
2843     }
2844     else {
2845       i_ppixf($self->{IMG}, $x, $y, $color);
2846     }
2847   }
2848
2849   $self;
2850 }
2851
2852 sub getpixel {
2853   my $self = shift;
2854
2855   my %opts = ( "type"=>'8bit', @_);
2856
2857   unless (exists $opts{'x'} && exists $opts{'y'}) {
2858     $self->{ERRSTR} = 'missing x and y parameters';
2859     return undef;
2860   }
2861
2862   my $x = $opts{'x'};
2863   my $y = $opts{'y'};
2864   if (ref $x && ref $y) {
2865     unless (@$x == @$y) {
2866       $self->{ERRSTR} = 'length of x and y mismatch';
2867       return undef;
2868     }
2869     my @result;
2870     if ($opts{"type"} eq '8bit') {
2871       for my $i (0..$#{$opts{'x'}}) {
2872         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2873       }
2874     }
2875     else {
2876       for my $i (0..$#{$opts{'x'}}) {
2877         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2878       }
2879     }
2880     return wantarray ? @result : \@result;
2881   }
2882   else {
2883     if ($opts{"type"} eq '8bit') {
2884       return i_get_pixel($self->{IMG}, $x, $y);
2885     }
2886     else {
2887       return i_gpixf($self->{IMG}, $x, $y);
2888     }
2889   }
2890
2891   $self;
2892 }
2893
2894 sub getscanline {
2895   my $self = shift;
2896   my %opts = ( type => '8bit', x=>0, @_);
2897
2898   $self->_valid_image or return;
2899
2900   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2901
2902   unless (defined $opts{'y'}) {
2903     $self->_set_error("missing y parameter");
2904     return;
2905   }
2906
2907   if ($opts{type} eq '8bit') {
2908     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2909                   $opts{'y'});
2910   }
2911   elsif ($opts{type} eq 'float') {
2912     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2913                   $opts{'y'});
2914   }
2915   elsif ($opts{type} eq 'index') {
2916     unless (i_img_type($self->{IMG})) {
2917       $self->_set_error("type => index only valid on paletted images");
2918       return;
2919     }
2920     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
2921                   $opts{'y'});
2922   }
2923   else {
2924     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2925     return;
2926   }
2927 }
2928
2929 sub setscanline {
2930   my $self = shift;
2931   my %opts = ( x=>0, @_);
2932
2933   $self->_valid_image or return;
2934
2935   unless (defined $opts{'y'}) {
2936     $self->_set_error("missing y parameter");
2937     return;
2938   }
2939
2940   if (!$opts{type}) {
2941     if (ref $opts{pixels} && @{$opts{pixels}}) {
2942       # try to guess the type
2943       if ($opts{pixels}[0]->isa('Imager::Color')) {
2944         $opts{type} = '8bit';
2945       }
2946       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
2947         $opts{type} = 'float';
2948       }
2949       else {
2950         $self->_set_error("missing type parameter and could not guess from pixels");
2951         return;
2952       }
2953     }
2954     else {
2955       # default
2956       $opts{type} = '8bit';
2957     }
2958   }
2959
2960   if ($opts{type} eq '8bit') {
2961     if (ref $opts{pixels}) {
2962       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2963     }
2964     else {
2965       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2966     }
2967   }
2968   elsif ($opts{type} eq 'float') {
2969     if (ref $opts{pixels}) {
2970       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2971     }
2972     else {
2973       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2974     }
2975   }
2976   elsif ($opts{type} eq 'index') {
2977     if (ref $opts{pixels}) {
2978       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2979     }
2980     else {
2981       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2982     }
2983   }
2984   else {
2985     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2986     return;
2987   }
2988 }
2989
2990 sub getsamples {
2991   my $self = shift;
2992   my %opts = ( type => '8bit', x=>0, @_);
2993
2994   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2995
2996   unless (defined $opts{'y'}) {
2997     $self->_set_error("missing y parameter");
2998     return;
2999   }
3000
3001   unless ($opts{channels}) {
3002     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3003   }
3004
3005   if ($opts{type} eq '8bit') {
3006     return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3007                    $opts{y}, @{$opts{channels}});
3008   }
3009   elsif ($opts{type} eq 'float') {
3010     return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3011                     $opts{y}, @{$opts{channels}});
3012   }
3013   else {
3014     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3015     return;
3016   }
3017 }
3018
3019 # make an identity matrix of the given size
3020 sub _identity {
3021   my ($size) = @_;
3022
3023   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3024   for my $c (0 .. ($size-1)) {
3025     $matrix->[$c][$c] = 1;
3026   }
3027   return $matrix;
3028 }
3029
3030 # general function to convert an image
3031 sub convert {
3032   my ($self, %opts) = @_;
3033   my $matrix;
3034
3035   unless (defined wantarray) {
3036     my @caller = caller;
3037     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3038     return;
3039   }
3040
3041   # the user can either specify a matrix or preset
3042   # the matrix overrides the preset
3043   if (!exists($opts{matrix})) {
3044     unless (exists($opts{preset})) {
3045       $self->{ERRSTR} = "convert() needs a matrix or preset";
3046       return;
3047     }
3048     else {
3049       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3050         # convert to greyscale, keeping the alpha channel if any
3051         if ($self->getchannels == 3) {
3052           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3053         }
3054         elsif ($self->getchannels == 4) {
3055           # preserve the alpha channel
3056           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3057                       [ 0,     0,     0,     1 ] ];
3058         }
3059         else {
3060           # an identity
3061           $matrix = _identity($self->getchannels);
3062         }
3063       }
3064       elsif ($opts{preset} eq 'noalpha') {
3065         # strip the alpha channel
3066         if ($self->getchannels == 2 or $self->getchannels == 4) {
3067           $matrix = _identity($self->getchannels);
3068           pop(@$matrix); # lose the alpha entry
3069         }
3070         else {
3071           $matrix = _identity($self->getchannels);
3072         }
3073       }
3074       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3075         # extract channel 0
3076         $matrix = [ [ 1 ] ];
3077       }
3078       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3079         $matrix = [ [ 0, 1 ] ];
3080       }
3081       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3082         $matrix = [ [ 0, 0, 1 ] ];
3083       }
3084       elsif ($opts{preset} eq 'alpha') {
3085         if ($self->getchannels == 2 or $self->getchannels == 4) {
3086           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3087         }
3088         else {
3089           # the alpha is just 1 <shrug>
3090           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3091         }
3092       }
3093       elsif ($opts{preset} eq 'rgb') {
3094         if ($self->getchannels == 1) {
3095           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3096         }
3097         elsif ($self->getchannels == 2) {
3098           # preserve the alpha channel
3099           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3100         }
3101         else {
3102           $matrix = _identity($self->getchannels);
3103         }
3104       }
3105       elsif ($opts{preset} eq 'addalpha') {
3106         if ($self->getchannels == 1) {
3107           $matrix = _identity(2);
3108         }
3109         elsif ($self->getchannels == 3) {
3110           $matrix = _identity(4);
3111         }
3112         else {
3113           $matrix = _identity($self->getchannels);
3114         }
3115       }
3116       else {
3117         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3118         return undef;
3119       }
3120     }
3121   }
3122   else {
3123     $matrix = $opts{matrix};
3124   }
3125
3126   my $new = Imager->new();
3127   $new->{IMG} = i_img_new();
3128   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
3129     # most likely a bad matrix
3130     $self->{ERRSTR} = _error_as_msg();
3131     return undef;
3132   }
3133   return $new;
3134 }
3135
3136
3137 # general function to map an image through lookup tables
3138
3139 sub map {
3140   my ($self, %opts) = @_;
3141   my @chlist = qw( red green blue alpha );
3142
3143   if (!exists($opts{'maps'})) {
3144     # make maps from channel maps
3145     my $chnum;
3146     for $chnum (0..$#chlist) {
3147       if (exists $opts{$chlist[$chnum]}) {
3148         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3149       } elsif (exists $opts{'all'}) {
3150         $opts{'maps'}[$chnum] = $opts{'all'};
3151       }
3152     }
3153   }
3154   if ($opts{'maps'} and $self->{IMG}) {
3155     i_map($self->{IMG}, $opts{'maps'} );
3156   }
3157   return $self;
3158 }
3159
3160 sub difference {
3161   my ($self, %opts) = @_;
3162
3163   defined $opts{mindist} or $opts{mindist} = 0;
3164
3165   defined $opts{other}
3166     or return $self->_set_error("No 'other' parameter supplied");
3167   defined $opts{other}{IMG}
3168     or return $self->_set_error("No image data in 'other' image");
3169
3170   $self->{IMG}
3171     or return $self->_set_error("No image data");
3172
3173   my $result = Imager->new;
3174   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3175                                 $opts{mindist})
3176     or return $self->_set_error($self->_error_as_msg());
3177
3178   return $result;
3179 }
3180
3181 # destructive border - image is shrunk by one pixel all around
3182
3183 sub border {
3184   my ($self,%opts)=@_;
3185   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3186   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3187 }
3188
3189
3190 # Get the width of an image
3191
3192 sub getwidth {
3193   my $self = shift;
3194   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3195   return (i_img_info($self->{IMG}))[0];
3196 }
3197
3198 # Get the height of an image
3199
3200 sub getheight {
3201   my $self = shift;
3202   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3203   return (i_img_info($self->{IMG}))[1];
3204 }
3205
3206 # Get number of channels in an image
3207
3208 sub getchannels {
3209   my $self = shift;
3210   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3211   return i_img_getchannels($self->{IMG});
3212 }
3213
3214 # Get channel mask
3215
3216 sub getmask {
3217   my $self = shift;
3218   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3219   return i_img_getmask($self->{IMG});
3220 }
3221
3222 # Set channel mask
3223
3224 sub setmask {
3225   my $self = shift;
3226   my %opts = @_;
3227   if (!defined($self->{IMG})) {
3228     $self->{ERRSTR} = 'image is empty';
3229     return undef;
3230   }
3231   unless (defined $opts{mask}) {
3232     $self->_set_error("mask parameter required");
3233     return;
3234   }
3235   i_img_setmask( $self->{IMG} , $opts{mask} );
3236
3237   1;
3238 }
3239
3240 # Get number of colors in an image
3241
3242 sub getcolorcount {
3243   my $self=shift;
3244   my %opts=('maxcolors'=>2**30,@_);
3245   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3246   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3247   return ($rc==-1? undef : $rc);
3248 }
3249
3250 # draw string to an image
3251
3252 sub string {
3253   my $self = shift;
3254   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3255
3256   my %input=('x'=>0, 'y'=>0, @_);
3257   $input{string}||=$input{text};
3258
3259   unless(defined $input{string}) {
3260     $self->{ERRSTR}="missing required parameter 'string'";
3261     return;
3262   }
3263
3264   unless($input{font}) {
3265     $self->{ERRSTR}="missing required parameter 'font'";
3266     return;
3267   }
3268
3269   unless ($input{font}->draw(image=>$self, %input)) {
3270     return;
3271   }
3272
3273   return $self;
3274 }
3275
3276 sub align_string {
3277   my $self = shift;
3278
3279   my $img;
3280   if (ref $self) {
3281     unless ($self->{IMG}) {
3282       $self->{ERRSTR}='empty input image';
3283       return;
3284     }
3285     $img = $self;
3286   }
3287   else {
3288     $img = undef;
3289   }
3290
3291   my %input=('x'=>0, 'y'=>0, @_);
3292   $input{string}||=$input{text};
3293
3294   unless(exists $input{string}) {
3295     $self->_set_error("missing required parameter 'string'");
3296     return;
3297   }
3298
3299   unless($input{font}) {
3300     $self->_set_error("missing required parameter 'font'");
3301     return;
3302   }
3303
3304   my @result;
3305   unless (@result = $input{font}->align(image=>$img, %input)) {
3306     return;
3307   }
3308
3309   return wantarray ? @result : $result[0];
3310 }
3311
3312 my @file_limit_names = qw/width height bytes/;
3313
3314 sub set_file_limits {
3315   shift;
3316
3317   my %opts = @_;
3318   my %values;
3319
3320   if ($opts{reset}) {
3321     @values{@file_limit_names} = (0) x @file_limit_names;
3322   }
3323   else {
3324     @values{@file_limit_names} = i_get_image_file_limits();
3325   }
3326
3327   for my $key (keys %values) {
3328     defined $opts{$key} and $values{$key} = $opts{$key};
3329   }
3330
3331   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3332 }
3333
3334 sub get_file_limits {
3335   i_get_image_file_limits();
3336 }
3337
3338 # Shortcuts that can be exported
3339
3340 sub newcolor { Imager::Color->new(@_); }
3341 sub newfont  { Imager::Font->new(@_); }
3342
3343 *NC=*newcolour=*newcolor;
3344 *NF=*newfont;
3345
3346 *open=\&read;
3347 *circle=\&arc;
3348
3349
3350 #### Utility routines
3351
3352 sub errstr {
3353   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3354 }
3355
3356 sub _set_error {
3357   my ($self, $msg) = @_;
3358
3359   if (ref $self) {
3360     $self->{ERRSTR} = $msg;
3361   }
3362   else {
3363     $ERRSTR = $msg;
3364   }
3365   return;
3366 }
3367
3368 # Default guess for the type of an image from extension
3369
3370 sub def_guess_type {
3371   my $name=lc(shift);
3372   my $ext;
3373   $ext=($name =~ m/\.([^\.]+)$/)[0];
3374   return 'tiff' if ($ext =~ m/^tiff?$/);
3375   return 'jpeg' if ($ext =~ m/^jpe?g$/);
3376   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
3377   return 'png'  if ($ext eq "png");
3378   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
3379   return 'tga'  if ($ext eq "tga");
3380   return 'rgb'  if ($ext eq "rgb");
3381   return 'gif'  if ($ext eq "gif");
3382   return 'raw'  if ($ext eq "raw");
3383   return lc $ext; # best guess
3384   return ();
3385 }
3386
3387 # get the minimum of a list
3388
3389 sub _min {
3390   my $mx=shift;
3391   for(@_) { if ($_<$mx) { $mx=$_; }}
3392   return $mx;
3393 }
3394
3395 # get the maximum of a list
3396
3397 sub _max {
3398   my $mx=shift;
3399   for(@_) { if ($_>$mx) { $mx=$_; }}
3400   return $mx;
3401 }
3402
3403 # string stuff for iptc headers
3404
3405 sub _clean {
3406   my($str)=$_[0];
3407   $str = substr($str,3);
3408   $str =~ s/[\n\r]//g;
3409   $str =~ s/\s+/ /g;
3410   $str =~ s/^\s//;
3411   $str =~ s/\s$//;
3412   return $str;
3413 }
3414
3415 # A little hack to parse iptc headers.
3416
3417 sub parseiptc {
3418   my $self=shift;
3419   my(@sar,$item,@ar);
3420   my($caption,$photogr,$headln,$credit);
3421
3422   my $str=$self->{IPTCRAW};
3423
3424   defined $str
3425     or return;
3426
3427   @ar=split(/8BIM/,$str);
3428
3429   my $i=0;
3430   foreach (@ar) {
3431     if (/^\004\004/) {
3432       @sar=split(/\034\002/);
3433       foreach $item (@sar) {
3434         if ($item =~ m/^x/) {
3435           $caption = _clean($item);
3436           $i++;
3437         }
3438         if ($item =~ m/^P/) {
3439           $photogr = _clean($item);
3440           $i++;
3441         }
3442         if ($item =~ m/^i/) {
3443           $headln = _clean($item);
3444           $i++;
3445         }
3446         if ($item =~ m/^n/) {
3447           $credit = _clean($item);
3448           $i++;
3449         }
3450       }
3451     }
3452   }
3453   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3454 }
3455
3456 sub Inline {
3457   my ($lang) = @_;
3458
3459   $lang eq 'C'
3460     or die "Only C language supported";
3461
3462   require Imager::ExtUtils;
3463   return Imager::ExtUtils->inline_config;
3464 }
3465
3466 1;
3467 __END__
3468 # Below is the stub of documentation for your module. You better edit it!
3469
3470 =head1 NAME
3471
3472 Imager - Perl extension for Generating 24 bit Images
3473
3474 =head1 SYNOPSIS
3475
3476   # Thumbnail example
3477
3478   #!/usr/bin/perl -w
3479   use strict;
3480   use Imager;
3481
3482   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3483   my $file = shift;
3484
3485   my $format;
3486
3487   my $img = Imager->new();
3488   # see Imager::Files for information on the read() method
3489   $img->read(file=>$file) or die $img->errstr();
3490
3491   $file =~ s/\.[^.]*$//;
3492
3493   # Create smaller version
3494   # documented in Imager::Transformations
3495   my $thumb = $img->scale(scalefactor=>.3);
3496
3497   # Autostretch individual channels
3498   $thumb->filter(type=>'autolevels');
3499
3500   # try to save in one of these formats
3501   SAVE:
3502
3503   for $format ( qw( png gif jpg tiff ppm ) ) {
3504     # Check if given format is supported
3505     if ($Imager::formats{$format}) {
3506       $file.="_low.$format";
3507       print "Storing image as: $file\n";
3508       # documented in Imager::Files
3509       $thumb->write(file=>$file) or
3510         die $thumb->errstr;
3511       last SAVE;
3512     }
3513   }
3514
3515 =head1 DESCRIPTION
3516
3517 Imager is a module for creating and altering images.  It can read and
3518 write various image formats, draw primitive shapes like lines,and
3519 polygons, blend multiple images together in various ways, scale, crop,
3520 render text and more.
3521
3522 =head2 Overview of documentation
3523
3524 =over
3525
3526 =item *
3527
3528 Imager - This document - Synopsis, Example, Table of Contents and
3529 Overview.
3530
3531 =item *
3532
3533 L<Imager::Tutorial> - a brief introduction to Imager.
3534
3535 =item *
3536
3537 L<Imager::Cookbook> - how to do various things with Imager.
3538
3539 =item *
3540
3541 L<Imager::ImageTypes> - Basics of constructing image objects with
3542 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
3543 8/16/double bits/channel, color maps, channel masks, image tags, color
3544 quantization.  Also discusses basic image information methods.
3545
3546 =item *
3547
3548 L<Imager::Files> - IO interaction, reading/writing images, format
3549 specific tags.
3550
3551 =item *
3552
3553 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
3554 flood fill.
3555
3556 =item *
3557
3558 L<Imager::Color> - Color specification.
3559
3560 =item *
3561
3562 L<Imager::Fill> - Fill pattern specification.
3563
3564 =item *
3565
3566 L<Imager::Font> - General font rendering, bounding boxes and font
3567 metrics.
3568
3569 =item *
3570
3571 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
3572 blending, pasting, convert and map.
3573
3574 =item *
3575
3576 L<Imager::Engines> - Programmable transformations through
3577 C<transform()>, C<transform2()> and C<matrix_transform()>.
3578
3579 =item *
3580
3581 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
3582 filter plugins.
3583
3584 =item *
3585
3586 L<Imager::Expr> - Expressions for evaluation engine used by
3587 transform2().
3588
3589 =item *
3590
3591 L<Imager::Matrix2d> - Helper class for affine transformations.
3592
3593 =item *
3594
3595 L<Imager::Fountain> - Helper for making gradient profiles.
3596
3597 =item *
3598
3599 L<Imager::API> - using Imager's C API
3600
3601 =item *
3602
3603 L<Imager::APIRef> - API function reference
3604
3605 =item *
3606
3607 L<Imager::Inline> - using Imager's C API from Inline::C
3608
3609 =item *
3610
3611 L<Imager::ExtUtils> - tools to get access to Imager's C API.
3612
3613 =back
3614
3615 =head2 Basic Overview
3616
3617 An Image object is created with C<$img = Imager-E<gt>new()>.
3618 Examples:
3619
3620   $img=Imager->new();                         # create empty image
3621   $img->read(file=>'lena.png',type=>'png') or # read image from file
3622      die $img->errstr();                      # give an explanation
3623                                               # if something failed
3624
3625 or if you want to create an empty image:
3626
3627   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3628
3629 This example creates a completely black image of width 400 and height
3630 300 and 4 channels.
3631
3632 =head1 ERROR HANDLING
3633
3634 In general a method will return false when it fails, if it does use the errstr() method to find out why:
3635
3636 =over
3637
3638 =item errstr
3639
3640 Returns the last error message in that context.
3641
3642 If the last error you received was from calling an object method, such
3643 as read, call errstr() as an object method to find out why:
3644
3645   my $image = Imager->new;
3646   $image->read(file => 'somefile.gif')
3647      or die $image->errstr;
3648
3649 If it was a class method then call errstr() as a class method:
3650
3651   my @imgs = Imager->read_multi(file => 'somefile.gif')
3652     or die Imager->errstr;
3653
3654 Note that in some cases object methods are implemented in terms of
3655 class methods so a failing object method may set both.
3656
3657 =back
3658
3659 The C<Imager-E<gt>new> method is described in detail in
3660 L<Imager::ImageTypes>.
3661
3662 =head1 METHOD INDEX
3663
3664 Where to find information on methods for Imager class objects.
3665
3666 addcolors() -  L<Imager::ImageTypes/addcolors>
3667
3668 addtag() -  L<Imager::ImageTypes/addtag> - add image tags
3669
3670 align_string() - L<Imager::Draw/align_string>
3671
3672 arc() - L<Imager::Draw/arc>
3673
3674 bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
3675 image
3676
3677 box() - L<Imager::Draw/box>
3678
3679 circle() - L<Imager::Draw/circle>
3680
3681 colorcount() - L<Imager::Draw/colorcount>
3682
3683 convert() - L<Imager::Transformations/"Color transformations"> -
3684 transform the color space
3685
3686 copy() - L<Imager::Transformations/copy>
3687
3688 crop() - L<Imager::Transformations/crop> - extract part of an image
3689
3690 def_guess_type() - L<Imager::Files/def_guess_type>
3691
3692 deltag() -  L<Imager::ImageTypes/deltag> - delete image tags
3693
3694 difference() - L<Imager::Filters/"Image Difference">
3695
3696 errstr() - L<"Basic Overview">
3697
3698 filter() - L<Imager::Filters>
3699
3700 findcolor() - L<Imager::ImageTypes/findcolor> - search the image palette, if it
3701 has one
3702
3703 flip() - L<Imager::Transformations/flip>
3704
3705 flood_fill() - L<Imager::Draw/flood_fill>
3706
3707 getchannels() -  L<Imager::ImageTypes/getchannels>
3708
3709 getcolorcount() -  L<Imager::ImageTypes/getcolorcount>
3710
3711 getcolors() - L<Imager::ImageTypes/getcolors> - get colors from the image
3712 palette, if it has one
3713
3714 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3715
3716 getheight() - L<Imager::ImageTypes/getwidth>
3717
3718 getmask() - L<Imager::ImageTypes/getmask>
3719
3720 getpixel() - L<Imager::Draw/getpixel>
3721
3722 getsamples() - L<Imager::Draw/getsamples>
3723
3724 getscanline() - L<Imager::Draw/getscanline>
3725
3726 getwidth() - L<Imager::ImageTypes/getwidth>
3727
3728 img_set() - L<Imager::ImageTypes/img_set>
3729
3730 init() - L<Imager::ImageTypes/init>
3731
3732 line() - L<Imager::Draw/line>
3733
3734 load_plugin() - L<Imager::Filters/load_plugin>
3735
3736 map() - L<Imager::Transformations/"Color Mappings"> - remap color
3737 channel values
3738
3739 masked() -  L<Imager::ImageTypes/masked> - make a masked image
3740
3741 matrix_transform() - L<Imager::Engines/matrix_transform>
3742
3743 maxcolors() - L<Imager::ImageTypes/maxcolors>
3744
3745 NC() - L<Imager::Handy/NC>
3746
3747 new() - L<Imager::ImageTypes/new>
3748
3749 newcolor() - L<Imager::Handy/newcolor>
3750
3751 newcolour() - L<Imager::Handy/newcolour>
3752
3753 newfont() - L<Imager::Handy/newfont>
3754
3755 NF() - L<Imager::Handy/NF>
3756
3757 open() - L<Imager::Files> - an alias for read()
3758
3759 parseiptc() - L<Imager::Files/parseiptc> - parse IPTC data from a JPEG
3760 image
3761
3762 paste() - L<Imager::Transformations/paste> - draw an image onto an image
3763
3764 polygon() - L<Imager::Draw/polygon>
3765
3766 polyline() - L<Imager::Draw/polyline>
3767
3768 read() - L<Imager::Files> - read a single image from an image file
3769
3770 read_multi() - L<Imager::Files> - read multiple images from an image
3771 file
3772
3773 register_filter() - L<Imager::Filters/register_filter>
3774
3775 register_reader() - L<Imager::Filters/register_reader>
3776
3777 register_writer() - L<Imager::Filters/register_writer>
3778
3779 rotate() - L<Imager::Transformations/rotate>
3780
3781 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
3782 image and use the alpha channel
3783
3784 scale() - L<Imager::Transformations/scale>
3785
3786 scaleX() - L<Imager::Transformations/scaleX>
3787
3788 scaleY() - L<Imager::Transformations/scaleY>
3789
3790 setcolors() - L<Imager::ImageTypes/setcolors> - set palette colors in
3791 a paletted image
3792
3793 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3794
3795 setmask() - L<Imager::ImageTypes/setmask>
3796
3797 setpixel() - L<Imager::Draw/setpixel>
3798
3799 setscanline() - L<Imager::Draw/setscanline>
3800
3801 settag() - L<Imager::ImageTypes/settag>
3802
3803 string() - L<Imager::Draw/string> - draw text on an image
3804
3805 tags() -  L<Imager::ImageTypes/tags> - fetch image tags
3806
3807 to_paletted() -  L<Imager::ImageTypes/to_paletted>
3808
3809 to_rgb8() - L<Imager::ImageTypes/to_rgb8>
3810
3811 transform() - L<Imager::Engines/"transform">
3812
3813 transform2() - L<Imager::Engines/"transform2">
3814
3815 type() -  L<Imager::ImageTypes/type> - type of image (direct vs paletted)
3816
3817 unload_plugin() - L<Imager::Filters/unload_plugin>
3818
3819 virtual() - L<Imager::ImageTypes/virtual> - whether the image has it's own
3820 data
3821
3822 write() - L<Imager::Files> - write an image to a file
3823
3824 write_multi() - L<Imager::Files> - write multiple image to an image
3825 file.
3826
3827 =head1 CONCEPT INDEX
3828
3829 animated GIF - L<Imager::File/"Writing an animated GIF">
3830
3831 aspect ratio - L<Imager::ImageTypes/i_xres>,
3832 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
3833
3834 blend - alpha blending one image onto another
3835 L<Imager::Transformations/rubthrough>
3836
3837 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
3838
3839 boxes, drawing - L<Imager::Draw/box>
3840
3841 changes between image - L<Imager::Filter/"Image Difference">
3842
3843 color - L<Imager::Color>
3844
3845 color names - L<Imager::Color>, L<Imager::Color::Table>
3846
3847 combine modes - L<Imager::Fill/combine>
3848
3849 compare images - L<Imager::Filter/"Image Difference">
3850
3851 contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
3852
3853 convolution - L<Imager::Filter/conv>
3854
3855 cropping - L<Imager::Transformations/crop>
3856
3857 C<diff> images - L<Imager::Filter/"Image Difference">
3858
3859 dpi - L<Imager::ImageTypes/i_xres>,
3860 L<Imager::Cookbook/"Image spatial resolution">
3861
3862 drawing boxes - L<Imager::Draw/box>
3863
3864 drawing lines - L<Imager::Draw/line>
3865
3866 drawing text - L<Imager::Draw/string>, L<Imager::Draw/align_string>
3867
3868 error message - L<"Basic Overview">
3869
3870 files, font - L<Imager::Font>
3871
3872 files, image - L<Imager::Files>
3873
3874 filling, types of fill - L<Imager::Fill>
3875
3876 filling, boxes - L<Imager::Draw/box>
3877
3878 filling, flood fill - L<Imager::Draw/flood_fill>
3879
3880 flood fill - L<Imager::Draw/flood_fill>
3881
3882 fonts - L<Imager::Font>
3883
3884 fonts, drawing with - L<Imager::Draw/string>,
3885 L<Imager::Draw/align_string>, L<Imager::Font::Wrap>
3886
3887 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3888
3889 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
3890
3891 fountain fill - L<Imager::Fill/"Fountain fills">,
3892 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3893 L<Imager::Filters/gradgen>
3894
3895 GIF files - L<Imager::Files/"GIF">
3896
3897 GIF files, animated - L<Imager::File/"Writing an animated GIF">
3898
3899 gradient fill - L<Imager::Fill/"Fountain fills">,
3900 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3901 L<Imager::Filters/gradgen>
3902
3903 guassian blur - L<Imager::Filter/guassian>
3904
3905 hatch fills - L<Imager::Fill/"Hatched fills">
3906
3907 invert image - L<Imager::Filter/hardinvert>
3908
3909 JPEG - L<Imager::Files/"JPEG">
3910
3911 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
3912
3913 lines, drawing - L<Imager::Draw/line>
3914
3915 matrix - L<Imager::Matrix2d>,
3916 L<Imager::Transformations/"Matrix Transformations">,
3917 L<Imager::Font/transform>
3918
3919 metadata, image - L<Imager::ImageTypes/"Tags">
3920
3921 mosaic - L<Imager::Filter/mosaic>
3922
3923 noise, filter - L<Imager::Filter/noise>
3924
3925 noise, rendered - L<Imager::Filter/turbnoise>,
3926 L<Imager::Filter/radnoise>
3927
3928 paste - L<Imager::Transformations/paste>,
3929 L<Imager::Transformations/rubthrough>
3930
3931 pseudo-color image - L<Imager::ImageTypes/to_paletted>,
3932 L<Imager::ImageTypes/new>
3933
3934 posterize - L<Imager::Filter/postlevels>
3935
3936 png files - L<Imager::Files>, L<Imager::Files/"PNG">
3937
3938 pnm - L<Imager::Files/"PNM (Portable aNy Map)">
3939
3940 rectangles, drawing - L<Imager::Draw/box>
3941
3942 resizing an image - L<Imager::Transformations/scale>,
3943 L<Imager::Transformations/crop>
3944
3945 saving an image - L<Imager::Files>
3946
3947 scaling - L<Imager::Transformations/scale>
3948
3949 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
3950
3951 size, image - L<Imager::ImageTypes/getwidth>,
3952 L<Imager::ImageTypes/getheight>
3953
3954 size, text - L<Imager::Font/bounding_box>
3955
3956 tags, image metadata - L<Imager::ImageTypes/"Tags">
3957
3958 text, drawing - L<Imager::Draw/string>, L<Imager::Draw/align_string>,
3959 L<Imager::Font::Wrap>
3960
3961 text, wrapping text in an area - L<Imager::Font::Wrap>
3962
3963 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3964
3965 tiles, color - L<Imager::Filter/mosaic>
3966
3967 unsharp mask - L<Imager::Filter/unsharpmask>
3968
3969 watermark - L<Imager::Filter/watermark>
3970
3971 writing an image to a file - L<Imager::Files>
3972
3973 =head1 SUPPORT
3974
3975 The best place to get help with Imager is the mailing list.
3976
3977 To subscribe send a message with C<subscribe> in the body to:
3978
3979    imager-devel+request@molar.is
3980
3981 or use the form at:
3982
3983 =over
3984
3985 L<http://www.molar.is/en/lists/imager-devel/>
3986
3987 =back
3988
3989 where you can also find the mailing list archive.
3990
3991 You can report bugs by pointing your browser at:
3992
3993 =over
3994
3995 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
3996
3997 =back
3998
3999 Please remember to include the versions of Imager, perl, supporting
4000 libraries, and any relevant code.  If you have specific images that
4001 cause the problems, please include those too.
4002
4003 =head1 BUGS
4004
4005 Bugs are listed individually for relevant pod pages.
4006
4007 =head1 AUTHOR
4008
4009 Arnar M. Hrafnkelsson and Tony Cook (tony@imager.perl.org) among
4010 others. See the README for a complete list.
4011
4012 =head1 SEE ALSO
4013
4014 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4015 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4016 L<Imager::Font>(3), L<Imager::Transformations>(3),
4017 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4018 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4019
4020 L<http://imager.perl.org/>
4021
4022 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4023
4024 Other perl imaging modules include:
4025
4026 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3).
4027
4028 =cut