Imager.pm

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