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