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 = '0.98';
 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   my ($lang) = @_;
4200
4201   $lang eq 'C'
4202     or die "Only C language supported";
4203
4204   require Imager::ExtUtils;
4205   return Imager::ExtUtils->inline_config;
4206 }
4207
4208 # threads shouldn't try to close raw Imager objects
4209 sub Imager::ImgRaw::CLONE_SKIP { 1 }
4210
4211 sub preload {
4212   # this serves two purposes:
4213   # - a class method to load the file support modules included with Imager
4214   #   (or were included, once the library dependent modules are split out)
4215   # - something for Module::ScanDeps to analyze
4216   # https://rt.cpan.org/Ticket/Display.html?id=6566
4217   local $@;
4218   eval { require Imager::File::GIF };
4219   eval { require Imager::File::JPEG };
4220   eval { require Imager::File::PNG };
4221   eval { require Imager::File::SGI };
4222   eval { require Imager::File::TIFF };
4223   eval { require Imager::File::ICO };
4224   eval { require Imager::Font::W32 };
4225   eval { require Imager::Font::FT2 };
4226   eval { require Imager::Font::T1 };
4227 }
4228
4229 package Imager::IO;
4230 use IO::Seekable;
4231
4232 sub new_fh {
4233   my ($class, $fh) = @_;
4234
4235   if (tied(*$fh)) {
4236     return $class->new_cb
4237       (
4238        sub {
4239          local $\;
4240
4241          return print $fh $_[0];
4242        },
4243        sub {
4244          my $tmp;
4245          my $count = CORE::read $fh, $tmp, $_[1];
4246          defined $count
4247            or return undef;
4248          $count
4249            or return "";
4250          return $tmp;
4251        },
4252        sub {
4253          if ($_[1] != SEEK_CUR || $_[0] != 0) {
4254            unless (CORE::seek $fh, $_[0], $_[1]) {
4255              return -1;
4256            }
4257          }
4258
4259          return tell $fh;
4260        },
4261        undef,
4262       );
4263   }
4264   else {
4265     return $class->_new_perlio($fh);
4266   }
4267 }
4268
4269 # backward compatibility for %formats
4270 package Imager::FORMATS;
4271 use strict;
4272 use constant IX_FORMATS => 0;
4273 use constant IX_LIST => 1;
4274 use constant IX_INDEX => 2;
4275 use constant IX_CLASSES => 3;
4276
4277 sub TIEHASH {
4278   my ($class, $formats, $classes) = @_;
4279
4280   return bless [ $formats, [ ], 0, $classes ], $class;
4281 }
4282
4283 sub _check {
4284   my ($self, $key) = @_;
4285
4286   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4287   my $value;
4288   my $error;
4289   my $loaded = Imager::_load_file($file, \$error);
4290   if ($loaded) {
4291     $value = 1;
4292   }
4293   else {
4294     if ($error =~ /^Can't locate /) {
4295       $error = "Can't locate $file";
4296     }
4297     $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
4298     $value = undef;
4299   }
4300   $self->[IX_FORMATS]{$key} = $value;
4301
4302   return $value;
4303 }
4304
4305 sub FETCH {
4306   my ($self, $key) = @_;
4307
4308   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4309
4310   $self->[IX_CLASSES]{$key} or return undef;
4311
4312   return $self->_check($key);
4313 }
4314
4315 sub STORE {
4316   die "%Imager::formats is not user monifiable";
4317 }
4318
4319 sub DELETE {
4320   die "%Imager::formats is not user monifiable";
4321 }
4322
4323 sub CLEAR {
4324   die "%Imager::formats is not user monifiable";
4325 }
4326
4327 sub EXISTS {
4328   my ($self, $key) = @_;
4329
4330   if (exists $self->[IX_FORMATS]{$key}) {
4331     my $value = $self->[IX_FORMATS]{$key}
4332       or return;
4333     return 1;
4334   }
4335
4336   $self->_check($key) or return 1==0;
4337
4338   return 1==1;
4339 }
4340
4341 sub FIRSTKEY {
4342   my ($self) = @_;
4343
4344   unless (@{$self->[IX_LIST]}) {
4345     # full populate it
4346     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4347       keys %{$self->[IX_FORMATS]};
4348
4349     for my $key (keys %{$self->[IX_CLASSES]}) {
4350       $self->[IX_FORMATS]{$key} and next;
4351       $self->_check($key)
4352         and push @{$self->[IX_LIST]}, $key;
4353     }
4354   }
4355
4356   @{$self->[IX_LIST]} or return;
4357   $self->[IX_INDEX] = 1;
4358   return $self->[IX_LIST][0];
4359 }
4360
4361 sub NEXTKEY {
4362   my ($self) = @_;
4363
4364   $self->[IX_INDEX] < @{$self->[IX_LIST]}
4365     or return;
4366
4367   return $self->[IX_LIST][$self->[IX_INDEX]++];
4368 }
4369
4370 sub SCALAR {
4371   my ($self) = @_;
4372
4373   return scalar @{$self->[IX_LIST]};
4374 }
4375
4376 1;
4377 __END__
4378 # Below is the stub of documentation for your module. You better edit it!
4379
4380 =head1 NAME
4381
4382 Imager - Perl extension for Generating 24 bit Images
4383
4384 =head1 SYNOPSIS
4385
4386   # Thumbnail example
4387
4388   #!/usr/bin/perl -w
4389   use strict;
4390   use Imager;
4391
4392   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
4393   my $file = shift;
4394
4395   my $format;
4396
4397   # see Imager::Files for information on the read() method
4398   my $img = Imager->new(file=>$file)
4399     or die Imager->errstr();
4400
4401   $file =~ s/\.[^.]*$//;
4402
4403   # Create smaller version
4404   # documented in Imager::Transformations
4405   my $thumb = $img->scale(scalefactor=>.3);
4406
4407   # Autostretch individual channels
4408   $thumb->filter(type=>'autolevels');
4409
4410   # try to save in one of these formats
4411   SAVE:
4412
4413   for $format ( qw( png gif jpeg tiff ppm ) ) {
4414     # Check if given format is supported
4415     if ($Imager::formats{$format}) {
4416       $file.="_low.$format";
4417       print "Storing image as: $file\n";
4418       # documented in Imager::Files
4419       $thumb->write(file=>$file) or
4420         die $thumb->errstr;
4421       last SAVE;
4422     }
4423   }
4424
4425 =head1 DESCRIPTION
4426
4427 Imager is a module for creating and altering images.  It can read and
4428 write various image formats, draw primitive shapes like lines,and
4429 polygons, blend multiple images together in various ways, scale, crop,
4430 render text and more.
4431
4432 =head2 Overview of documentation
4433
4434 =over
4435
4436 =item *
4437
4438 Imager - This document - Synopsis, Example, Table of Contents and
4439 Overview.
4440
4441 =item *
4442
4443 L<Imager::Install> - installation notes for Imager.
4444
4445 =item *
4446
4447 L<Imager::Tutorial> - a brief introduction to Imager.
4448
4449 =item *
4450
4451 L<Imager::Cookbook> - how to do various things with Imager.
4452
4453 =item *
4454
4455 L<Imager::ImageTypes> - Basics of constructing image objects with
4456 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4457 8/16/double bits/channel, color maps, channel masks, image tags, color
4458 quantization.  Also discusses basic image information methods.
4459
4460 =item *
4461
4462 L<Imager::Files> - IO interaction, reading/writing images, format
4463 specific tags.
4464
4465 =item *
4466
4467 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4468 flood fill.
4469
4470 =item *
4471
4472 L<Imager::Color> - Color specification.
4473
4474 =item *
4475
4476 L<Imager::Fill> - Fill pattern specification.
4477
4478 =item *
4479
4480 L<Imager::Font> - General font rendering, bounding boxes and font
4481 metrics.
4482
4483 =item *
4484
4485 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4486 blending, pasting, convert and map.
4487
4488 =item *
4489
4490 L<Imager::Engines> - Programmable transformations through
4491 C<transform()>, C<transform2()> and C<matrix_transform()>.
4492
4493 =item *
4494
4495 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4496 filter plug-ins.
4497
4498 =item *
4499
4500 L<Imager::Expr> - Expressions for evaluation engine used by
4501 transform2().
4502
4503 =item *
4504
4505 L<Imager::Matrix2d> - Helper class for affine transformations.
4506
4507 =item *
4508
4509 L<Imager::Fountain> - Helper for making gradient profiles.
4510
4511 =item *
4512
4513 L<Imager::IO> - Imager I/O abstraction.
4514
4515 =item *
4516
4517 L<Imager::API> - using Imager's C API
4518
4519 =item *
4520
4521 L<Imager::APIRef> - API function reference
4522
4523 =item *
4524
4525 L<Imager::Inline> - using Imager's C API from Inline::C
4526
4527 =item *
4528
4529 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4530
4531 =item *
4532
4533 L<Imager::Security> - brief security notes.
4534
4535 =item *
4536
4537 L<Imager::Threads> - brief information on working with threads.
4538
4539 =back
4540
4541 =head2 Basic Overview
4542
4543 An Image object is created with C<$img = Imager-E<gt>new()>.
4544 Examples:
4545
4546   $img=Imager->new();                         # create empty image
4547   $img->read(file=>'lena.png',type=>'png') or # read image from file
4548      die $img->errstr();                      # give an explanation
4549                                               # if something failed
4550
4551 or if you want to create an empty image:
4552
4553   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4554
4555 This example creates a completely black image of width 400 and height
4556 300 and 4 channels.
4557
4558 =head1 ERROR HANDLING
4559
4560 In general a method will return false when it fails, if it does use
4561 the C<errstr()> method to find out why:
4562
4563 =over
4564
4565 =item errstr()
4566
4567 Returns the last error message in that context.
4568
4569 If the last error you received was from calling an object method, such
4570 as read, call errstr() as an object method to find out why:
4571
4572   my $image = Imager->new;
4573   $image->read(file => 'somefile.gif')
4574      or die $image->errstr;
4575
4576 If it was a class method then call errstr() as a class method:
4577
4578   my @imgs = Imager->read_multi(file => 'somefile.gif')
4579     or die Imager->errstr;
4580
4581 Note that in some cases object methods are implemented in terms of
4582 class methods so a failing object method may set both.
4583
4584 =back
4585
4586 The C<Imager-E<gt>new> method is described in detail in
4587 L<Imager::ImageTypes>.
4588
4589 =head1 METHOD INDEX
4590
4591 Where to find information on methods for Imager class objects.
4592
4593 addcolors() - L<Imager::ImageTypes/addcolors()> - add colors to a
4594 paletted image
4595
4596 addtag() -  L<Imager::ImageTypes/addtag()> - add image tags
4597
4598 align_string() - L<Imager::Draw/align_string()> - draw text aligned on a
4599 point
4600
4601 arc() - L<Imager::Draw/arc()> - draw a filled arc
4602
4603 bits() - L<Imager::ImageTypes/bits()> - number of bits per sample for the
4604 image
4605
4606 box() - L<Imager::Draw/box()> - draw a filled or outline box.
4607
4608 check_file_limits() - L<Imager::Files/check_file_limits()>
4609
4610 circle() - L<Imager::Draw/circle()> - draw a filled circle
4611
4612 close_log() - L<Imager::ImageTypes/close_log()> - close the Imager
4613 debugging log.
4614
4615 colorcount() - L<Imager::ImageTypes/colorcount()> - the number of
4616 colors in an image's palette (paletted images only)
4617
4618 combine() - L<Imager::Transformations/combine()> - combine channels
4619 from one or more images.
4620
4621 combines() - L<Imager::Draw/combines()> - return a list of the
4622 different combine type keywords
4623
4624 compose() - L<Imager::Transformations/compose()> - compose one image
4625 over another.
4626
4627 convert() - L<Imager::Transformations/convert()> - transform the color
4628 space
4629
4630 copy() - L<Imager::Transformations/copy()> - make a duplicate of an
4631 image
4632
4633 crop() - L<Imager::Transformations/crop()> - extract part of an image
4634
4635 def_guess_type() - L<Imager::Files/def_guess_type()> - default function
4636 used to guess the output file format based on the output file name
4637
4638 deltag() -  L<Imager::ImageTypes/deltag()> - delete image tags
4639
4640 difference() - L<Imager::Filters/difference()> - produce a difference
4641 images from two input images.
4642
4643 errstr() - L</errstr()> - the error from the last failed operation.
4644
4645 filter() - L<Imager::Filters/filter()> - image filtering
4646
4647 findcolor() - L<Imager::ImageTypes/findcolor()> - search the image
4648 palette, if it has one
4649
4650 flip() - L<Imager::Transformations/flip()> - flip an image, vertically,
4651 horizontally
4652
4653 flood_fill() - L<Imager::Draw/flood_fill()> - fill an enclosed or same
4654 color area
4655
4656 getchannels() - L<Imager::ImageTypes/getchannels()> - the number of
4657 samples per pixel for an image
4658
4659 getcolorcount() - L<Imager::ImageTypes/getcolorcount()> - the number of
4660 different colors used by an image (works for direct color images)
4661
4662 getcolors() - L<Imager::ImageTypes/getcolors()> - get colors from the image
4663 palette, if it has one
4664
4665 getcolorusage() - L<Imager::ImageTypes/getcolorusage()>
4666
4667 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash()>
4668
4669 get_file_limits() - L<Imager::Files/get_file_limits()>
4670
4671 getheight() - L<Imager::ImageTypes/getheight()> - height of the image in
4672 pixels
4673
4674 getmask() - L<Imager::ImageTypes/getmask()> - write mask for the image
4675
4676 getpixel() - L<Imager::Draw/getpixel()> - retrieve one or more pixel
4677 colors
4678
4679 getsamples() - L<Imager::Draw/getsamples()> - retrieve samples from a
4680 row or partial row of pixels.
4681
4682 getscanline() - L<Imager::Draw/getscanline()> - retrieve colors for a
4683 row or partial row of pixels.
4684
4685 getwidth() - L<Imager::ImageTypes/getwidth()> - width of the image in
4686 pixels.
4687
4688 img_set() - L<Imager::ImageTypes/img_set()> - re-use an Imager object
4689 for a new image.
4690
4691 init() - L<Imager::ImageTypes/init()>
4692
4693 is_bilevel() - L<Imager::ImageTypes/is_bilevel()> - returns whether
4694 image write functions should write the image in their bilevel (blank
4695 and white, no gray levels) format
4696
4697 is_logging() L<Imager::ImageTypes/is_logging()> - test if the debug
4698 log is active.
4699
4700 line() - L<Imager::Draw/line()> - draw an interval
4701
4702 load_plugin() - L<Imager::Filters/load_plugin()>
4703
4704 log() - L<Imager::ImageTypes/log()> - send a message to the debugging
4705 log.
4706
4707 make_palette() - L<Imager::ImageTypes/make_palette()> - produce a
4708 color palette from one or more input images.
4709
4710 map() - L<Imager::Transformations/map()> - remap color
4711 channel values
4712
4713 masked() -  L<Imager::ImageTypes/masked()> - make a masked image
4714
4715 matrix_transform() - L<Imager::Engines/matrix_transform()>
4716
4717 maxcolors() - L<Imager::ImageTypes/maxcolors()>
4718
4719 NC() - L<Imager::Handy/NC()>
4720
4721 NCF() - L<Imager::Handy/NCF()>
4722
4723 new() - L<Imager::ImageTypes/new()>
4724
4725 newcolor() - L<Imager::Handy/newcolor()>
4726
4727 newcolour() - L<Imager::Handy/newcolour()>
4728
4729 newfont() - L<Imager::Handy/newfont()>
4730
4731 NF() - L<Imager::Handy/NF()>
4732
4733 open() - L<Imager::Files/read()> - an alias for read()
4734
4735 open_log() - L<Imager::ImageTypes/open_log()> - open the debug log.
4736
4737 =for stopwords IPTC
4738
4739 parseiptc() - L<Imager::Files/parseiptc()> - parse IPTC data from a JPEG
4740 image
4741
4742 paste() - L<Imager::Transformations/paste()> - draw an image onto an
4743 image
4744
4745 polygon() - L<Imager::Draw/polygon()>
4746
4747 polyline() - L<Imager::Draw/polyline()>
4748
4749 preload() - L<Imager::Files/preload()>
4750
4751 read() - L<Imager::Files/read()> - read a single image from an image file
4752
4753 read_multi() - L<Imager::Files/read_multi()> - read multiple images from an image
4754 file
4755
4756 read_types() - L<Imager::Files/read_types()> - list image types Imager
4757 can read.
4758
4759 register_filter() - L<Imager::Filters/register_filter()>
4760
4761 register_reader() - L<Imager::Files/register_reader()>
4762
4763 register_writer() - L<Imager::Files/register_writer()>
4764
4765 rotate() - L<Imager::Transformations/rotate()>
4766
4767 rubthrough() - L<Imager::Transformations/rubthrough()> - draw an image
4768 onto an image and use the alpha channel
4769
4770 scale() - L<Imager::Transformations/scale()>
4771
4772 scale_calculate() - L<Imager::Transformations/scale_calculate()>
4773
4774 scaleX() - L<Imager::Transformations/scaleX()>
4775
4776 scaleY() - L<Imager::Transformations/scaleY()>
4777
4778 setcolors() - L<Imager::ImageTypes/setcolors()> - set palette colors
4779 in a paletted image
4780
4781 set_file_limits() - L<Imager::Files/set_file_limits()>
4782
4783 setmask() - L<Imager::ImageTypes/setmask()>
4784
4785 setpixel() - L<Imager::Draw/setpixel()>
4786
4787 setsamples() - L<Imager::Draw/setsamples()>
4788
4789 setscanline() - L<Imager::Draw/setscanline()>
4790
4791 settag() - L<Imager::ImageTypes/settag()>
4792
4793 string() - L<Imager::Draw/string()> - draw text on an image
4794
4795 tags() -  L<Imager::ImageTypes/tags()> - fetch image tags
4796
4797 to_paletted() -  L<Imager::ImageTypes/to_paletted()>
4798
4799 to_rgb16() - L<Imager::ImageTypes/to_rgb16()>
4800
4801 to_rgb8() - L<Imager::ImageTypes/to_rgb8()>
4802
4803 to_rgb_double() - L<Imager::ImageTypes/to_rgb_double()> - convert to
4804 double per sample image.
4805
4806 transform() - L<Imager::Engines/"transform()">
4807
4808 transform2() - L<Imager::Engines/"transform2()">
4809
4810 type() -  L<Imager::ImageTypes/type()> - type of image (direct vs paletted)
4811
4812 unload_plugin() - L<Imager::Filters/unload_plugin()>
4813
4814 virtual() - L<Imager::ImageTypes/virtual()> - whether the image has it's own
4815 data
4816
4817 write() - L<Imager::Files/write()> - write an image to a file
4818
4819 write_multi() - L<Imager::Files/write_multi()> - write multiple image to an image
4820 file.
4821
4822 write_types() - L<Imager::Files/read_types()> - list image types Imager
4823 can write.
4824
4825 =head1 CONCEPT INDEX
4826
4827 animated GIF - L<Imager::Files/"Writing an animated GIF">
4828
4829 aspect ratio - C<i_xres>, C<i_yres>, C<i_aspect_only> in
4830 L<Imager::ImageTypes/"Common Tags">.
4831
4832 blend - alpha blending one image onto another
4833 L<Imager::Transformations/rubthrough()>
4834
4835 blur - L<Imager::Filters/gaussian>, L<Imager::Filters/conv>
4836
4837 boxes, drawing - L<Imager::Draw/box()>
4838
4839 changes between image - L<Imager::Filters/"Image Difference">
4840
4841 channels, combine into one image - L<Imager::Transformations/combine()>
4842
4843 color - L<Imager::Color>
4844
4845 color names - L<Imager::Color>, L<Imager::Color::Table>
4846
4847 combine modes - L<Imager::Draw/"Combine Types">
4848
4849 compare images - L<Imager::Filters/"Image Difference">
4850
4851 contrast - L<Imager::Filters/contrast>, L<Imager::Filters/autolevels>
4852
4853 convolution - L<Imager::Filters/conv>
4854
4855 cropping - L<Imager::Transformations/crop()>
4856
4857 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4858
4859 C<diff> images - L<Imager::Filters/"Image Difference">
4860
4861 dpi - C<i_xres>, C<i_yres> in L<Imager::ImageTypes/"Common Tags">,
4862 L<Imager::Cookbook/"Image spatial resolution">
4863
4864 drawing boxes - L<Imager::Draw/box()>
4865
4866 drawing lines - L<Imager::Draw/line()>
4867
4868 drawing text - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>
4869
4870 error message - L</"ERROR HANDLING">
4871
4872 files, font - L<Imager::Font>
4873
4874 files, image - L<Imager::Files>
4875
4876 filling, types of fill - L<Imager::Fill>
4877
4878 filling, boxes - L<Imager::Draw/box()>
4879
4880 filling, flood fill - L<Imager::Draw/flood_fill()>
4881
4882 flood fill - L<Imager::Draw/flood_fill()>
4883
4884 fonts - L<Imager::Font>
4885
4886 fonts, drawing with - L<Imager::Draw/string()>,
4887 L<Imager::Draw/align_string()>, L<Imager::Font::Wrap>
4888
4889 fonts, metrics - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4890
4891 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4892
4893 fountain fill - L<Imager::Fill/"Fountain fills">,
4894 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4895 L<Imager::Filters/gradgen>
4896
4897 GIF files - L<Imager::Files/"GIF">
4898
4899 GIF files, animated - L<Imager::Files/"Writing an animated GIF">
4900
4901 gradient fill - L<Imager::Fill/"Fountain fills">,
4902 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4903 L<Imager::Filters/gradgen>
4904
4905 gray scale, convert image to - L<Imager::Transformations/convert()>
4906
4907 gaussian blur - L<Imager::Filters/gaussian>
4908
4909 hatch fills - L<Imager::Fill/"Hatched fills">
4910
4911 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4912
4913 invert image - L<Imager::Filters/hardinvert>,
4914 L<Imager::Filters/hardinvertall>
4915
4916 JPEG - L<Imager::Files/"JPEG">
4917
4918 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4919
4920 lines, drawing - L<Imager::Draw/line()>
4921
4922 matrix - L<Imager::Matrix2d>,
4923 L<Imager::Engines/"Matrix Transformations">,
4924 L<Imager::Font/transform()>
4925
4926 metadata, image - L<Imager::ImageTypes/"Tags">, L<Image::ExifTool>
4927
4928 mosaic - L<Imager::Filters/mosaic>
4929
4930 noise, filter - L<Imager::Filters/noise>
4931
4932 noise, rendered - L<Imager::Filters/turbnoise>,
4933 L<Imager::Filters/radnoise>
4934
4935 paste - L<Imager::Transformations/paste()>,
4936 L<Imager::Transformations/rubthrough()>
4937
4938 pseudo-color image - L<Imager::ImageTypes/to_paletted()>,
4939 L<Imager::ImageTypes/new()>
4940
4941 =for stopwords posterize
4942
4943 posterize - L<Imager::Filters/postlevels>
4944
4945 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
4946
4947 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
4948
4949 rectangles, drawing - L<Imager::Draw/box()>
4950
4951 resizing an image - L<Imager::Transformations/scale()>,
4952 L<Imager::Transformations/crop()>
4953
4954 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4955
4956 saving an image - L<Imager::Files>
4957
4958 scaling - L<Imager::Transformations/scale()>
4959
4960 security - L<Imager::Security>
4961
4962 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4963
4964 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4965
4966 size, image - L<Imager::ImageTypes/getwidth()>,
4967 L<Imager::ImageTypes/getheight()>
4968
4969 size, text - L<Imager::Font/bounding_box()>
4970
4971 tags, image metadata - L<Imager::ImageTypes/"Tags">
4972
4973 text, drawing - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>,
4974 L<Imager::Font::Wrap>
4975
4976 text, wrapping text in an area - L<Imager::Font::Wrap>
4977
4978 text, measuring - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4979
4980 threads - L<Imager::Threads>
4981
4982 tiles, color - L<Imager::Filters/mosaic>
4983
4984 transparent images - L<Imager::ImageTypes>,
4985 L<Imager::Cookbook/"Transparent PNG">
4986
4987 =for stopwords unsharp
4988
4989 unsharp mask - L<Imager::Filters/unsharpmask>
4990
4991 watermark - L<Imager::Filters/watermark>
4992
4993 writing an image to a file - L<Imager::Files>
4994
4995 =head1 SUPPORT
4996
4997 The best place to get help with Imager is the mailing list.
4998
4999 To subscribe send a message with C<subscribe> in the body to:
5000
5001    imager-devel+request@molar.is
5002
5003 or use the form at:
5004
5005 =over
5006
5007 L<http://www.molar.is/en/lists/imager-devel/>
5008
5009 =back
5010
5011 where you can also find the mailing list archive.
5012
5013 You can report bugs by pointing your browser at:
5014
5015 =over
5016
5017 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
5018
5019 =back
5020
5021 or by sending an email to:
5022
5023 =over
5024
5025 bug-Imager@rt.cpan.org
5026
5027 =back
5028
5029 Please remember to include the versions of Imager, perl, supporting
5030 libraries, and any relevant code.  If you have specific images that
5031 cause the problems, please include those too.
5032
5033 If you don't want to publish your email address on a mailing list you
5034 can use CPAN::Forum:
5035
5036   http://www.cpanforum.com/dist/Imager
5037
5038 You will need to register to post.
5039
5040 =head1 CONTRIBUTING TO IMAGER
5041
5042 =head2 Feedback
5043
5044 I like feedback.
5045
5046 If you like or dislike Imager, you can add a public review of Imager
5047 at CPAN Ratings:
5048
5049   http://cpanratings.perl.org/dist/Imager
5050
5051 =for stopwords Bitcard
5052
5053 This requires a Bitcard account (http://www.bitcard.org).
5054
5055 You can also send email to the maintainer below.
5056
5057 If you send me a bug report via email, it will be copied to Request
5058 Tracker.
5059
5060 =head2 Patches
5061
5062 I accept patches, preferably against the master branch in git.  Please
5063 include an explanation of the reason for why the patch is needed or
5064 useful.
5065
5066 Your patch should include regression tests where possible, otherwise
5067 it will be delayed until I get a chance to write them.
5068
5069 To browse Imager's git repository:
5070
5071   http://git.imager.perl.org/imager.git
5072
5073 To clone:
5074
5075   git clone git://git.imager.perl.org/imager.git
5076
5077 My preference is that patches are provided in the format produced by
5078 C<git format-patch>, for example, if you made your changes in a branch
5079 from master you might do:
5080
5081   git format-patch -k --stdout master >my-patch.txt
5082
5083 and then attach that to your bug report, either by adding it as an
5084 attachment in your email client, or by using the Request Tracker
5085 attachment mechanism.
5086
5087 =head1 AUTHOR
5088
5089 Tony Cook <tonyc@cpan.org> is the current maintainer for Imager.
5090
5091 Arnar M. Hrafnkelsson is the original author of Imager.
5092
5093 Many others have contributed to Imager, please see the C<README> for a
5094 complete list.
5095
5096 =head1 LICENSE
5097
5098 Imager is licensed under the same terms as perl itself.
5099
5100 =for stopwords
5101 makeblendedfont Fontforge
5102
5103 A test font, generated by the Debian packaged Fontforge,
5104 F<FT2/fontfiles/MMOne.pfb>, contains a Postscript operator definition
5105 copyrighted by Adobe.  See F<adobe.txt> in the source for license
5106 information.
5107
5108 =head1 SEE ALSO
5109
5110 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
5111 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
5112 L<Imager::Font>(3), L<Imager::Transformations>(3),
5113 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
5114 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
5115
5116 L<http://imager.perl.org/>
5117
5118 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
5119
5120 Other perl imaging modules include:
5121
5122 L<GD>(3), L<Image::Magick>(3),
5123 L<Graphics::Magick|http://www.graphicsmagick.org/perl.html>(3),
5124 L<Prima::Image>, L<IPA>.
5125
5126 For manipulating image metadata see L<Image::ExifTool>.
5127
5128 If you're trying to use Imager for array processing, you should
5129 probably using L<PDL>.
5130
5131 =cut