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