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