Imager.pm

   1 package Imager;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR %OPCODES $I2P $FORMATGUESS $warn_obsolete);
   5 use IO::File;
   6 use Scalar::Util;
   7 use Imager::Color;
   8 use Imager::Font;
   9 use Config;
  10
  11 @EXPORT_OK = qw(
  12                 init
  13                 init_log
  14                 DSO_open
  15                 DSO_close
  16                 DSO_funclist
  17                 DSO_call
  18
  19                 load_plugin
  20                 unload_plugin
  21
  22                 i_list_formats
  23
  24                 i_color_new
  25                 i_color_set
  26                 i_color_info
  27
  28                 i_img_info
  29
  30                 i_img_setmask
  31                 i_img_getmask
  32
  33                 i_line
  34                 i_line_aa
  35                 i_box
  36                 i_box_filled
  37                 i_arc
  38                 i_circle_aa
  39
  40                 i_bezier_multi
  41                 i_poly_aa
  42                 i_poly_aa_cfill
  43
  44                 i_copyto
  45                 i_rubthru
  46                 i_scaleaxis
  47                 i_scale_nn
  48                 i_haar
  49                 i_count_colors
  50
  51                 i_gaussian
  52                 i_conv
  53
  54                 i_convert
  55                 i_map
  56
  57                 i_img_diff
  58
  59                 i_tt_set_aa
  60                 i_tt_cp
  61                 i_tt_text
  62                 i_tt_bbox
  63
  64                 i_readpnm_wiol
  65                 i_writeppm_wiol
  66
  67                 i_readraw_wiol
  68                 i_writeraw_wiol
  69
  70                 i_contrast
  71                 i_hardinvert
  72                 i_noise
  73                 i_bumpmap
  74                 i_postlevels
  75                 i_mosaic
  76                 i_watermark
  77
  78                 malloc_state
  79
  80                 list_formats
  81
  82                 i_gifquant
  83
  84                 newfont
  85                 newcolor
  86                 newcolour
  87                 NC
  88                 NF
  89                 NCF
  90 );
  91
  92 @EXPORT=qw(
  93           );
  94
  95 %EXPORT_TAGS=
  96   (handy => [qw(
  97                 newfont
  98                 newcolor
  99                 NF
 100                 NC
 101                 NCF
 102                )],
 103    all => [@EXPORT_OK],
 104    default => [qw(
 105                   load_plugin
 106                   unload_plugin
 107                  )]);
 108
 109 # registered file readers
 110 my %readers;
 111
 112 # registered file writers
 113 my %writers;
 114
 115 # modules we attempted to autoload
 116 my %attempted_to_load;
 117
 118 # errors from loading files
 119 my %file_load_errors;
 120
 121 # what happened when we tried to load
 122 my %reader_load_errors;
 123 my %writer_load_errors;
 124
 125 # library keys that are image file formats
 126 my %file_formats = map { $_ => 1 } qw/tiff pnm gif png jpeg raw bmp tga/;
 127
 128 # image pixel combine types
 129 my @combine_types =
 130   qw/none normal multiply dissolve add subtract diff lighten darken
 131      hue saturation value color/;
 132 my %combine_types;
 133 @combine_types{@combine_types} = 0 .. $#combine_types;
 134 $combine_types{mult} = $combine_types{multiply};
 135 $combine_types{'sub'}  = $combine_types{subtract};
 136 $combine_types{sat}  = $combine_types{saturation};
 137
 138 # this will be used to store global defaults at some point
 139 my %defaults;
 140
 141 BEGIN {
 142   require Exporter;
 143   my $ex_version = eval $Exporter::VERSION;
 144   if ($ex_version < 5.57) {
 145     @ISA = qw(Exporter);
 146   }
 147   $VERSION = '1.001';
 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       if ($opts{d1} == 0 && $opts{d2} == 361) {
2898         i_circle_aa_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2899                          $opts{fill}{fill});
2900       }
2901       else {
2902         i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2903                        $opts{'d2'}, $opts{fill}{fill});
2904       }
2905     }
2906     elsif ($opts{filled}) {
2907       my $color = _color($opts{'color'});
2908       unless ($color) {
2909         $self->{ERRSTR} = $Imager::ERRSTR;
2910         return;
2911       }
2912       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2913         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2914                     $color);
2915       }
2916       else {
2917         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2918                  $opts{'d1'}, $opts{'d2'}, $color);
2919       }
2920     }
2921     else {
2922       my $color = _color($opts{'color'});
2923       if ($opts{d2} - $opts{d1} >= 360) {
2924         $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2925       }
2926       else {
2927         $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2928       }
2929     }
2930   }
2931   else {
2932     if ($opts{fill}) {
2933       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2934         # assume it's a hash ref
2935         require 'Imager/Fill.pm';
2936         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2937           $self->{ERRSTR} = $Imager::ERRSTR;
2938           return;
2939         }
2940       }
2941       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2942                   $opts{'d2'}, $opts{fill}{fill});
2943     }
2944     else {
2945       my $color = _color($opts{'color'});
2946       unless ($color) {
2947         $self->{ERRSTR} = $Imager::ERRSTR;
2948         return;
2949       }
2950       if ($opts{filled}) {
2951         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2952               $opts{'d1'}, $opts{'d2'}, $color);
2953       }
2954       else {
2955         if ($opts{d1} == 0 && $opts{d2} == 361) {
2956           $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2957         }
2958         else {
2959           $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2960         }
2961       }
2962     }
2963   }
2964   unless ($good) {
2965     $self->_set_error($self->_error_as_msg);
2966     return;
2967   }
2968
2969   return $self;
2970 }
2971
2972 # Draws a line from one point to the other
2973 # the endpoint is set if the endp parameter is set which it is by default.
2974 # to turn of the endpoint being set use endp=>0 when calling line.
2975
2976 sub line {
2977   my $self=shift;
2978   my $dflcl=i_color_new(0,0,0,0);
2979   my %opts=(color=>$dflcl,
2980             endp => 1,
2981             @_);
2982
2983   $self->_valid_image("line")
2984     or return;
2985
2986   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2987   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2988
2989   my $color = _color($opts{'color'});
2990   unless ($color) {
2991     $self->{ERRSTR} = $Imager::ERRSTR;
2992     return;
2993   }
2994
2995   $opts{antialias} = $opts{aa} if defined $opts{aa};
2996   if ($opts{antialias}) {
2997     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2998               $color, $opts{endp});
2999   } else {
3000     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
3001            $color, $opts{endp});
3002   }
3003   return $self;
3004 }
3005
3006 # Draws a line between an ordered set of points - It more or less just transforms this
3007 # into a list of lines.
3008
3009 sub polyline {
3010   my $self=shift;
3011   my ($pt,$ls,@points);
3012   my $dflcl=i_color_new(0,0,0,0);
3013   my %opts=(color=>$dflcl,@_);
3014
3015   $self->_valid_image("polyline")
3016     or return;
3017
3018   if (exists($opts{points})) { @points=@{$opts{points}}; }
3019   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
3020     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
3021     }
3022
3023 #  print Dumper(\@points);
3024
3025   my $color = _color($opts{'color'});
3026   unless ($color) {
3027     $self->{ERRSTR} = $Imager::ERRSTR;
3028     return;
3029   }
3030   $opts{antialias} = $opts{aa} if defined $opts{aa};
3031   if ($opts{antialias}) {
3032     for $pt(@points) {
3033       if (defined($ls)) {
3034         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3035       }
3036       $ls=$pt;
3037     }
3038   } else {
3039     for $pt(@points) {
3040       if (defined($ls)) {
3041         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3042       }
3043       $ls=$pt;
3044     }
3045   }
3046   return $self;
3047 }
3048
3049 sub polygon {
3050   my $self = shift;
3051   my ($pt,$ls,@points);
3052   my $dflcl = i_color_new(0,0,0,0);
3053   my %opts = (color=>$dflcl, @_);
3054
3055   $self->_valid_image("polygon")
3056     or return;
3057
3058   if (exists($opts{points})) {
3059     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
3060     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
3061   }
3062
3063   if (!exists $opts{'x'} or !exists $opts{'y'})  {
3064     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
3065   }
3066
3067   if ($opts{'fill'}) {
3068     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
3069       # assume it's a hash ref
3070       require 'Imager/Fill.pm';
3071       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
3072         $self->{ERRSTR} = $Imager::ERRSTR;
3073         return undef;
3074       }
3075     }
3076     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
3077                     $opts{'fill'}{'fill'});
3078   }
3079   else {
3080     my $color = _color($opts{'color'});
3081     unless ($color) {
3082       $self->{ERRSTR} = $Imager::ERRSTR;
3083       return;
3084     }
3085     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3086   }
3087
3088   return $self;
3089 }
3090
3091
3092 # this the multipoint bezier curve
3093 # this is here more for testing that actual usage since
3094 # this is not a good algorithm.  Usually the curve would be
3095 # broken into smaller segments and each done individually.
3096
3097 sub polybezier {
3098   my $self=shift;
3099   my ($pt,$ls,@points);
3100   my $dflcl=i_color_new(0,0,0,0);
3101   my %opts=(color=>$dflcl,@_);
3102
3103   $self->_valid_image("polybezier")
3104     or return;
3105
3106   if (exists $opts{points}) {
3107     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
3108     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
3109   }
3110
3111   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
3112     $self->{ERRSTR}='Missing or invalid points.';
3113     return;
3114   }
3115
3116   my $color = _color($opts{'color'});
3117   unless ($color) {
3118     $self->{ERRSTR} = $Imager::ERRSTR;
3119     return;
3120   }
3121   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
3122   return $self;
3123 }
3124
3125 sub flood_fill {
3126   my $self = shift;
3127   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
3128   my $rc;
3129
3130   $self->_valid_image("flood_fill")
3131     or return;
3132
3133   unless (exists $opts{'x'} && exists $opts{'y'}) {
3134     $self->{ERRSTR} = "missing seed x and y parameters";
3135     return undef;
3136   }
3137
3138   if ($opts{border}) {
3139     my $border = _color($opts{border});
3140     unless ($border) {
3141       $self->_set_error($Imager::ERRSTR);
3142       return;
3143     }
3144     if ($opts{fill}) {
3145       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3146         # assume it's a hash ref
3147         require Imager::Fill;
3148         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3149           $self->{ERRSTR} = $Imager::ERRSTR;
3150           return;
3151         }
3152       }
3153       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3154                                  $opts{fill}{fill}, $border);
3155     }
3156     else {
3157       my $color = _color($opts{'color'});
3158       unless ($color) {
3159         $self->{ERRSTR} = $Imager::ERRSTR;
3160         return;
3161       }
3162       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3163                                 $color, $border);
3164     }
3165     if ($rc) {
3166       return $self;
3167     }
3168     else {
3169       $self->{ERRSTR} = $self->_error_as_msg();
3170       return;
3171     }
3172   }
3173   else {
3174     if ($opts{fill}) {
3175       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3176         # assume it's a hash ref
3177         require 'Imager/Fill.pm';
3178         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3179           $self->{ERRSTR} = $Imager::ERRSTR;
3180           return;
3181         }
3182       }
3183       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3184     }
3185     else {
3186       my $color = _color($opts{'color'});
3187       unless ($color) {
3188         $self->{ERRSTR} = $Imager::ERRSTR;
3189         return;
3190       }
3191       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3192     }
3193     if ($rc) {
3194       return $self;
3195     }
3196     else {
3197       $self->{ERRSTR} = $self->_error_as_msg();
3198       return;
3199     }
3200   }
3201 }
3202
3203 sub setpixel {
3204   my ($self, %opts) = @_;
3205
3206   $self->_valid_image("setpixel")
3207     or return;
3208
3209   my $color = $opts{color};
3210   unless (defined $color) {
3211     $color = $self->{fg};
3212     defined $color or $color = NC(255, 255, 255);
3213   }
3214
3215   unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3216     unless ($color = _color($color, 'setpixel')) {
3217       $self->_set_error("setpixel: " . Imager->errstr);
3218       return;
3219     }
3220   }
3221
3222   unless (exists $opts{'x'} && exists $opts{'y'}) {
3223     $self->_set_error('setpixel: missing x or y parameter');
3224     return;
3225   }
3226
3227   my $x = $opts{'x'};
3228   my $y = $opts{'y'};
3229   if (ref $x || ref $y) {
3230     $x = ref $x ? $x : [ $x ];
3231     $y = ref $y ? $y : [ $y ];
3232     unless (@$x) {
3233       $self->_set_error("setpixel: x is a reference to an empty array");
3234       return;
3235     }
3236     unless (@$y) {
3237       $self->_set_error("setpixel: y is a reference to an empty array");
3238       return;
3239     }
3240
3241     # make both the same length, replicating the last element
3242     if (@$x < @$y) {
3243       $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3244     }
3245     elsif (@$y < @$x) {
3246       $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3247     }
3248
3249     my $set = 0;
3250     if ($color->isa('Imager::Color')) {
3251       for my $i (0..$#$x) {
3252         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3253           or ++$set;
3254       }
3255     }
3256     else {
3257       for my $i (0..$#$x) {
3258         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3259           or ++$set;
3260       }
3261     }
3262
3263     return $set;
3264   }
3265   else {
3266     if ($color->isa('Imager::Color')) {
3267       i_ppix($self->{IMG}, $x, $y, $color)
3268         and return "0 but true";
3269     }
3270     else {
3271       i_ppixf($self->{IMG}, $x, $y, $color)
3272         and return "0 but true";
3273     }
3274
3275     return 1;
3276   }
3277 }
3278
3279 sub getpixel {
3280   my $self = shift;
3281
3282   my %opts = ( "type"=>'8bit', @_);
3283
3284   $self->_valid_image("getpixel")
3285     or return;
3286
3287   unless (exists $opts{'x'} && exists $opts{'y'}) {
3288     $self->_set_error('getpixel: missing x or y parameter');
3289     return;
3290   }
3291
3292   my $x = $opts{'x'};
3293   my $y = $opts{'y'};
3294   my $type = $opts{'type'};
3295   if (ref $x || ref $y) {
3296     $x = ref $x ? $x : [ $x ];
3297     $y = ref $y ? $y : [ $y ];
3298     unless (@$x) {
3299       $self->_set_error("getpixel: x is a reference to an empty array");
3300       return;
3301     }
3302     unless (@$y) {
3303       $self->_set_error("getpixel: y is a reference to an empty array");
3304       return;
3305     }
3306
3307     # make both the same length, replicating the last element
3308     if (@$x < @$y) {
3309       $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3310     }
3311     elsif (@$y < @$x) {
3312       $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3313     }
3314
3315     my @result;
3316     if ($type eq '8bit') {
3317       for my $i (0..$#$x) {
3318         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3319       }
3320     }
3321     elsif ($type eq 'float' || $type eq 'double') {
3322       for my $i (0..$#$x) {
3323         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3324       }
3325     }
3326     else {
3327       $self->_set_error("getpixel: type must be '8bit' or 'float'");
3328       return;
3329     }
3330     return wantarray ? @result : \@result;
3331   }
3332   else {
3333     if ($type eq '8bit') {
3334       return i_get_pixel($self->{IMG}, $x, $y);
3335     }
3336     elsif ($type eq 'float' || $type eq 'double') {
3337       return i_gpixf($self->{IMG}, $x, $y);
3338     }
3339     else {
3340       $self->_set_error("getpixel: type must be '8bit' or 'float'");
3341       return;
3342     }
3343   }
3344 }
3345
3346 sub getscanline {
3347   my $self = shift;
3348   my %opts = ( type => '8bit', x=>0, @_);
3349
3350   $self->_valid_image("getscanline")
3351     or return;
3352
3353   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3354
3355   unless (defined $opts{'y'}) {
3356     $self->_set_error("missing y parameter");
3357     return;
3358   }
3359
3360   if ($opts{type} eq '8bit') {
3361     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3362                   $opts{'y'});
3363   }
3364   elsif ($opts{type} eq 'float') {
3365     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3366                   $opts{'y'});
3367   }
3368   elsif ($opts{type} eq 'index') {
3369     unless (i_img_type($self->{IMG})) {
3370       $self->_set_error("type => index only valid on paletted images");
3371       return;
3372     }
3373     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3374                   $opts{'y'});
3375   }
3376   else {
3377     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3378     return;
3379   }
3380 }
3381
3382 sub setscanline {
3383   my $self = shift;
3384   my %opts = ( x=>0, @_);
3385
3386   $self->_valid_image("setscanline")
3387     or return;
3388
3389   unless (defined $opts{'y'}) {
3390     $self->_set_error("missing y parameter");
3391     return;
3392   }
3393
3394   if (!$opts{type}) {
3395     if (ref $opts{pixels} && @{$opts{pixels}}) {
3396       # try to guess the type
3397       if ($opts{pixels}[0]->isa('Imager::Color')) {
3398         $opts{type} = '8bit';
3399       }
3400       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3401         $opts{type} = 'float';
3402       }
3403       else {
3404         $self->_set_error("missing type parameter and could not guess from pixels");
3405         return;
3406       }
3407     }
3408     else {
3409       # default
3410       $opts{type} = '8bit';
3411     }
3412   }
3413
3414   if ($opts{type} eq '8bit') {
3415     if (ref $opts{pixels}) {
3416       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3417     }
3418     else {
3419       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3420     }
3421   }
3422   elsif ($opts{type} eq 'float') {
3423     if (ref $opts{pixels}) {
3424       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3425     }
3426     else {
3427       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3428     }
3429   }
3430   elsif ($opts{type} eq 'index') {
3431     if (ref $opts{pixels}) {
3432       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3433     }
3434     else {
3435       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3436     }
3437   }
3438   else {
3439     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3440     return;
3441   }
3442 }
3443
3444 sub getsamples {
3445   my $self = shift;
3446   my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3447
3448   $self->_valid_image("getsamples")
3449     or return;
3450
3451   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3452
3453   unless (defined $opts{'y'}) {
3454     $self->_set_error("missing y parameter");
3455     return;
3456   }
3457
3458   if ($opts{target}) {
3459     my $target = $opts{target};
3460     my $offset = $opts{offset};
3461     if ($opts{type} eq '8bit') {
3462       my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3463                             $opts{y}, $opts{channels})
3464         or return;
3465       @{$target}[$offset .. $offset + @samples - 1] = @samples;
3466       return scalar(@samples);
3467     }
3468     elsif ($opts{type} eq 'float') {
3469       my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3470                              $opts{y}, $opts{channels});
3471       @{$target}[$offset .. $offset + @samples - 1] = @samples;
3472       return scalar(@samples);
3473     }
3474     elsif ($opts{type} =~ /^(\d+)bit$/) {
3475       my $bits = $1;
3476
3477       my @data;
3478       my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3479                                $opts{y}, $bits, $target,
3480                                $offset, $opts{channels});
3481       unless (defined $count) {
3482         $self->_set_error(Imager->_error_as_msg);
3483         return;
3484       }
3485
3486       return $count;
3487     }
3488     else {
3489       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3490       return;
3491     }
3492   }
3493   else {
3494     if ($opts{type} eq '8bit') {
3495       return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3496                      $opts{y}, $opts{channels});
3497     }
3498     elsif ($opts{type} eq 'float') {
3499       return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3500                       $opts{y}, $opts{channels});
3501     }
3502     elsif ($opts{type} =~ /^(\d+)bit$/) {
3503       my $bits = $1;
3504
3505       my @data;
3506       i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3507                    $opts{y}, $bits, \@data, 0, $opts{channels})
3508         or return;
3509       return @data;
3510     }
3511     else {
3512       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3513       return;
3514     }
3515   }
3516 }
3517
3518 sub setsamples {
3519   my $self = shift;
3520
3521   $self->_valid_image("setsamples")
3522     or return;
3523
3524   my %opts = ( x => 0, offset => 0 );
3525   my $data_index;
3526   # avoid duplicating the data parameter, it may be a large scalar
3527   my $i = 0;
3528   while ($i < @_ -1) {
3529     if ($_[$i] eq 'data') {
3530       $data_index = $i+1;
3531     }
3532     else {
3533       $opts{$_[$i]} = $_[$i+1];
3534     }
3535
3536     $i += 2;
3537   }
3538
3539   unless(defined $data_index) {
3540     $self->_set_error('setsamples: data parameter missing');
3541     return;
3542   }
3543   unless (defined $_[$data_index]) {
3544     $self->_set_error('setsamples: data parameter not defined');
3545     return;
3546   }
3547
3548   my $type = $opts{type};
3549   defined $type or $type = '8bit';
3550
3551   my $width = defined $opts{width} ? $opts{width}
3552     : $self->getwidth() - $opts{x};
3553
3554   my $count;
3555   if ($type eq '8bit') {
3556     $count = i_psamp($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3557                      $_[$data_index], $opts{offset}, $width);
3558   }
3559   elsif ($type eq 'float') {
3560     $count = i_psampf($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3561                       $_[$data_index], $opts{offset}, $width);
3562   }
3563   elsif ($type =~ /^([0-9]+)bit$/) {
3564     my $bits = $1;
3565
3566     unless (ref $_[$data_index]) {
3567       $self->_set_error("setsamples: data must be an array ref for type not 8bit or float");
3568       return;
3569     }
3570
3571     $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3572                           $opts{channels}, $_[$data_index], $opts{offset},
3573                           $width);
3574   }
3575   else {
3576     $self->_set_error('setsamples: type parameter invalid');
3577     return;
3578   }
3579
3580   unless (defined $count) {
3581     $self->_set_error(Imager->_error_as_msg);
3582     return;
3583   }
3584
3585   return $count;
3586 }
3587
3588 # make an identity matrix of the given size
3589 sub _identity {
3590   my ($size) = @_;
3591
3592   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3593   for my $c (0 .. ($size-1)) {
3594     $matrix->[$c][$c] = 1;
3595   }
3596   return $matrix;
3597 }
3598
3599 # general function to convert an image
3600 sub convert {
3601   my ($self, %opts) = @_;
3602   my $matrix;
3603
3604   $self->_valid_image("convert")
3605     or return;
3606
3607   unless (defined wantarray) {
3608     my @caller = caller;
3609     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3610     return;
3611   }
3612
3613   # the user can either specify a matrix or preset
3614   # the matrix overrides the preset
3615   if (!exists($opts{matrix})) {
3616     unless (exists($opts{preset})) {
3617       $self->{ERRSTR} = "convert() needs a matrix or preset";
3618       return;
3619     }
3620     else {
3621       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3622         # convert to greyscale, keeping the alpha channel if any
3623         if ($self->getchannels == 3) {
3624           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3625         }
3626         elsif ($self->getchannels == 4) {
3627           # preserve the alpha channel
3628           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3629                       [ 0,     0,     0,     1 ] ];
3630         }
3631         else {
3632           # an identity
3633           $matrix = _identity($self->getchannels);
3634         }
3635       }
3636       elsif ($opts{preset} eq 'noalpha') {
3637         # strip the alpha channel
3638         if ($self->getchannels == 2 or $self->getchannels == 4) {
3639           $matrix = _identity($self->getchannels);
3640           pop(@$matrix); # lose the alpha entry
3641         }
3642         else {
3643           $matrix = _identity($self->getchannels);
3644         }
3645       }
3646       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3647         # extract channel 0
3648         $matrix = [ [ 1 ] ];
3649       }
3650       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3651         $matrix = [ [ 0, 1 ] ];
3652       }
3653       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3654         $matrix = [ [ 0, 0, 1 ] ];
3655       }
3656       elsif ($opts{preset} eq 'alpha') {
3657         if ($self->getchannels == 2 or $self->getchannels == 4) {
3658           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3659         }
3660         else {
3661           # the alpha is just 1 <shrug>
3662           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3663         }
3664       }
3665       elsif ($opts{preset} eq 'rgb') {
3666         if ($self->getchannels == 1) {
3667           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3668         }
3669         elsif ($self->getchannels == 2) {
3670           # preserve the alpha channel
3671           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3672         }
3673         else {
3674           $matrix = _identity($self->getchannels);
3675         }
3676       }
3677       elsif ($opts{preset} eq 'addalpha') {
3678         if ($self->getchannels == 1) {
3679           $matrix = _identity(2);
3680         }
3681         elsif ($self->getchannels == 3) {
3682           $matrix = _identity(4);
3683         }
3684         else {
3685           $matrix = _identity($self->getchannels);
3686         }
3687       }
3688       else {
3689         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3690         return undef;
3691       }
3692     }
3693   }
3694   else {
3695     $matrix = $opts{matrix};
3696   }
3697
3698   my $new = Imager->new;
3699   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3700   unless ($new->{IMG}) {
3701     # most likely a bad matrix
3702     i_push_error(0, "convert");
3703     $self->{ERRSTR} = _error_as_msg();
3704     return undef;
3705   }
3706   return $new;
3707 }
3708
3709 # combine channels from multiple input images, a class method
3710 sub combine {
3711   my ($class, %opts) = @_;
3712
3713   my $src = delete $opts{src};
3714   unless ($src) {
3715     $class->_set_error("src parameter missing");
3716     return;
3717   }
3718   my @imgs;
3719   my $index = 0;
3720   for my $img (@$src) {
3721     unless (eval { $img->isa("Imager") }) {
3722       $class->_set_error("src must contain image objects");
3723       return;
3724     }
3725     unless ($img->_valid_image("combine")) {
3726       $Imager::ERRSTR = $img->{ERRSTR} . " (src->[$index])";
3727       return;
3728     }
3729     push @imgs, $img->{IMG};
3730   }
3731   my $result;
3732   if (my $channels = delete $opts{channels}) {
3733     $result = i_combine(\@imgs, $channels);
3734   }
3735   else {
3736     $result = i_combine(\@imgs);
3737   }
3738   unless ($result) {
3739     $class->_set_error($class->_error_as_msg);
3740     return;
3741   }
3742
3743   my $img = $class->new;
3744   $img->{IMG} = $result;
3745
3746   return $img;
3747 }
3748
3749
3750 # general function to map an image through lookup tables
3751
3752 sub map {
3753   my ($self, %opts) = @_;
3754   my @chlist = qw( red green blue alpha );
3755
3756   $self->_valid_image("map")
3757     or return;
3758
3759   if (!exists($opts{'maps'})) {
3760     # make maps from channel maps
3761     my $chnum;
3762     for $chnum (0..$#chlist) {
3763       if (exists $opts{$chlist[$chnum]}) {
3764         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3765       } elsif (exists $opts{'all'}) {
3766         $opts{'maps'}[$chnum] = $opts{'all'};
3767       }
3768     }
3769   }
3770   if ($opts{'maps'} and $self->{IMG}) {
3771     i_map($self->{IMG}, $opts{'maps'} );
3772   }
3773   return $self;
3774 }
3775
3776 sub difference {
3777   my ($self, %opts) = @_;
3778
3779   $self->_valid_image("difference")
3780     or return;
3781
3782   defined $opts{mindist} or $opts{mindist} = 0;
3783
3784   defined $opts{other}
3785     or return $self->_set_error("No 'other' parameter supplied");
3786   unless ($opts{other}->_valid_image("difference")) {
3787     $self->_set_error($opts{other}->errstr . " (other image)");
3788     return;
3789   }
3790
3791   my $result = Imager->new;
3792   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3793                                 $opts{mindist})
3794     or return $self->_set_error($self->_error_as_msg());
3795
3796   return $result;
3797 }
3798
3799 # destructive border - image is shrunk by one pixel all around
3800
3801 sub border {
3802   my ($self,%opts)=@_;
3803   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3804   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3805 }
3806
3807
3808 # Get the width of an image
3809
3810 sub getwidth {
3811   my $self = shift;
3812
3813   $self->_valid_image("getwidth")
3814     or return;
3815
3816   return i_img_get_width($self->{IMG});
3817 }
3818
3819 # Get the height of an image
3820
3821 sub getheight {
3822   my $self = shift;
3823
3824   $self->_valid_image("getheight")
3825     or return;
3826
3827   return i_img_get_height($self->{IMG});
3828 }
3829
3830 # Get number of channels in an image
3831
3832 sub getchannels {
3833   my $self = shift;
3834
3835   $self->_valid_image("getchannels")
3836     or return;
3837
3838   return i_img_getchannels($self->{IMG});
3839 }
3840
3841 # Get channel mask
3842
3843 sub getmask {
3844   my $self = shift;
3845
3846   $self->_valid_image("getmask")
3847     or return;
3848
3849   return i_img_getmask($self->{IMG});
3850 }
3851
3852 # Set channel mask
3853
3854 sub setmask {
3855   my $self = shift;
3856   my %opts = @_;
3857
3858   $self->_valid_image("setmask")
3859     or return;
3860
3861   unless (defined $opts{mask}) {
3862     $self->_set_error("mask parameter required");
3863     return;
3864   }
3865
3866   i_img_setmask( $self->{IMG} , $opts{mask} );
3867
3868   1;
3869 }
3870
3871 # Get number of colors in an image
3872
3873 sub getcolorcount {
3874   my $self=shift;
3875   my %opts=('maxcolors'=>2**30,@_);
3876
3877   $self->_valid_image("getcolorcount")
3878     or return;
3879
3880   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3881   return ($rc==-1? undef : $rc);
3882 }
3883
3884 # Returns a reference to a hash. The keys are colour named (packed) and the
3885 # values are the number of pixels in this colour.
3886 sub getcolorusagehash {
3887   my $self = shift;
3888
3889   $self->_valid_image("getcolorusagehash")
3890     or return;
3891
3892   my %opts = ( maxcolors => 2**30, @_ );
3893   my $max_colors = $opts{maxcolors};
3894   unless (defined $max_colors && $max_colors > 0) {
3895     $self->_set_error('maxcolors must be a positive integer');
3896     return;
3897   }
3898
3899   my $channels= $self->getchannels;
3900   # We don't want to look at the alpha channel, because some gifs using it
3901   # doesn't define it for every colour (but only for some)
3902   $channels -= 1 if $channels == 2 or $channels == 4;
3903   my %color_use;
3904   my $height = $self->getheight;
3905   for my $y (0 .. $height - 1) {
3906     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3907     while (length $colors) {
3908       $color_use{ substr($colors, 0, $channels, '') }++;
3909     }
3910     keys %color_use > $max_colors
3911       and return;
3912   }
3913   return \%color_use;
3914 }
3915
3916 # This will return a ordered array of the colour usage. Kind of the sorted
3917 # version of the values of the hash returned by getcolorusagehash.
3918 # You might want to add safety checks and change the names, etc...
3919 sub getcolorusage {
3920   my $self = shift;
3921
3922   $self->_valid_image("getcolorusage")
3923     or return;
3924
3925   my %opts = ( maxcolors => 2**30, @_ );
3926   my $max_colors = $opts{maxcolors};
3927   unless (defined $max_colors && $max_colors > 0) {
3928     $self->_set_error('maxcolors must be a positive integer');
3929     return;
3930   }
3931
3932   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3933 }
3934
3935 # draw string to an image
3936
3937 sub string {
3938   my $self = shift;
3939
3940   $self->_valid_image("string")
3941     or return;
3942
3943   my %input=('x'=>0, 'y'=>0, @_);
3944   defined($input{string}) or $input{string} = $input{text};
3945
3946   unless(defined $input{string}) {
3947     $self->{ERRSTR}="missing required parameter 'string'";
3948     return;
3949   }
3950
3951   unless($input{font}) {
3952     $self->{ERRSTR}="missing required parameter 'font'";
3953     return;
3954   }
3955
3956   unless ($input{font}->draw(image=>$self, %input)) {
3957     return;
3958   }
3959
3960   return $self;
3961 }
3962
3963 sub align_string {
3964   my $self = shift;
3965
3966   my $img;
3967   if (ref $self) {
3968     $self->_valid_image("align_string")
3969       or return;
3970
3971     $img = $self;
3972   }
3973   else {
3974     $img = undef;
3975   }
3976
3977   my %input=('x'=>0, 'y'=>0, @_);
3978   defined $input{string}
3979     or $input{string} = $input{text};
3980
3981   unless(exists $input{string}) {
3982     $self->_set_error("missing required parameter 'string'");
3983     return;
3984   }
3985
3986   unless($input{font}) {
3987     $self->_set_error("missing required parameter 'font'");
3988     return;
3989   }
3990
3991   my @result;
3992   unless (@result = $input{font}->align(image=>$img, %input)) {
3993     return;
3994   }
3995
3996   return wantarray ? @result : $result[0];
3997 }
3998
3999 my @file_limit_names = qw/width height bytes/;
4000
4001 sub set_file_limits {
4002   shift;
4003
4004   my %opts = @_;
4005   my %values;
4006
4007   if ($opts{reset}) {
4008     @values{@file_limit_names} = (0) x @file_limit_names;
4009   }
4010   else {
4011     @values{@file_limit_names} = i_get_image_file_limits();
4012   }
4013
4014   for my $key (keys %values) {
4015     defined $opts{$key} and $values{$key} = $opts{$key};
4016   }
4017
4018   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
4019 }
4020
4021 sub get_file_limits {
4022   i_get_image_file_limits();
4023 }
4024
4025 my @check_args = qw(width height channels sample_size);
4026
4027 sub check_file_limits {
4028   my $class = shift;
4029
4030   my %opts =
4031     (
4032      channels => 3,
4033      sample_size => 1,
4034      @_,
4035     );
4036
4037   if ($opts{sample_size} && $opts{sample_size} eq 'float') {
4038     $opts{sample_size} = length(pack("d", 0));
4039   }
4040
4041   for my $name (@check_args) {
4042     unless (defined $opts{$name}) {
4043       $class->_set_error("check_file_limits: $name must be defined");
4044       return;
4045     }
4046     unless ($opts{$name} == int($opts{$name})) {
4047       $class->_set_error("check_file_limits: $name must be a positive integer");
4048       return;
4049     }
4050   }
4051
4052   my $result = i_int_check_image_file_limits(@opts{@check_args});
4053   unless ($result) {
4054     $class->_set_error($class->_error_as_msg());
4055   }
4056
4057   return $result;
4058 }
4059
4060 # Shortcuts that can be exported
4061
4062 sub newcolor { Imager::Color->new(@_); }
4063 sub newfont  { Imager::Font->new(@_); }
4064 sub NCF {
4065   require Imager::Color::Float;
4066   return Imager::Color::Float->new(@_);
4067 }
4068
4069 *NC=*newcolour=*newcolor;
4070 *NF=*newfont;
4071
4072 *open=\&read;
4073 *circle=\&arc;
4074
4075
4076 #### Utility routines
4077
4078 sub errstr {
4079   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
4080 }
4081
4082 sub _set_error {
4083   my ($self, $msg) = @_;
4084
4085   if (ref $self) {
4086     $self->{ERRSTR} = $msg;
4087   }
4088   else {
4089     $ERRSTR = $msg;
4090   }
4091   return;
4092 }
4093
4094 # Default guess for the type of an image from extension
4095
4096 my @simple_types = qw(png tga gif raw ico cur xpm mng jng ilbm pcx psd eps);
4097
4098 my %ext_types =
4099   (
4100    ( map { $_ => $_ } @simple_types ),
4101    tiff => "tiff",
4102    tif => "tiff",
4103    pbm => "pnm",
4104    pgm => "pnm",
4105    ppm => "pnm",
4106    pnm => "pnm", # technically wrong, but historically it works in Imager
4107    jpeg => "jpeg",
4108    jpg => "jpeg",
4109    bmp => "bmp",
4110    dib => "bmp",
4111    rgb => "sgi",
4112    bw => "sgi",
4113    sgi => "sgi",
4114    fit => "fits",
4115    fits => "fits",
4116    rle => "utah",
4117   );
4118
4119 sub def_guess_type {
4120   my $name=lc(shift);
4121
4122   my ($ext) = $name =~ /\.([^.]+)$/
4123     or return;
4124
4125   my $type = $ext_types{$ext}
4126     or return;
4127
4128   return $type;
4129 }
4130
4131 sub combines {
4132   return @combine_types;
4133 }
4134
4135 # get the minimum of a list
4136
4137 sub _min {
4138   my $mx=shift;
4139   for(@_) { if ($_<$mx) { $mx=$_; }}
4140   return $mx;
4141 }
4142
4143 # get the maximum of a list
4144
4145 sub _max {
4146   my $mx=shift;
4147   for(@_) { if ($_>$mx) { $mx=$_; }}
4148   return $mx;
4149 }
4150
4151 # string stuff for iptc headers
4152
4153 sub _clean {
4154   my($str)=$_[0];
4155   $str = substr($str,3);
4156   $str =~ s/[\n\r]//g;
4157   $str =~ s/\s+/ /g;
4158   $str =~ s/^\s//;
4159   $str =~ s/\s$//;
4160   return $str;
4161 }
4162
4163 # A little hack to parse iptc headers.
4164
4165 sub parseiptc {
4166   my $self=shift;
4167   my(@sar,$item,@ar);
4168   my($caption,$photogr,$headln,$credit);
4169
4170   my $str=$self->{IPTCRAW};
4171
4172   defined $str
4173     or return;
4174
4175   @ar=split(/8BIM/,$str);
4176
4177   my $i=0;
4178   foreach (@ar) {
4179     if (/^\004\004/) {
4180       @sar=split(/\034\002/);
4181       foreach $item (@sar) {
4182         if ($item =~ m/^x/) {
4183           $caption = _clean($item);
4184           $i++;
4185         }
4186         if ($item =~ m/^P/) {
4187           $photogr = _clean($item);
4188           $i++;
4189         }
4190         if ($item =~ m/^i/) {
4191           $headln = _clean($item);
4192           $i++;
4193         }
4194         if ($item =~ m/^n/) {
4195           $credit = _clean($item);
4196           $i++;
4197         }
4198       }
4199     }
4200   }
4201   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
4202 }
4203
4204 sub Inline {
4205   # Inline added a new argument at the beginning
4206   my $lang = $_[-1];
4207
4208   $lang eq 'C'
4209     or die "Only C language supported";
4210
4211   require Imager::ExtUtils;
4212   return Imager::ExtUtils->inline_config;
4213 }
4214
4215 # threads shouldn't try to close raw Imager objects
4216 sub Imager::ImgRaw::CLONE_SKIP { 1 }
4217
4218 sub preload {
4219   # this serves two purposes:
4220   # - a class method to load the file support modules included with Imager
4221   #   (or were included, once the library dependent modules are split out)
4222   # - something for Module::ScanDeps to analyze
4223   # https://rt.cpan.org/Ticket/Display.html?id=6566
4224   local $@;
4225   eval { require Imager::File::GIF };
4226   eval { require Imager::File::JPEG };
4227   eval { require Imager::File::PNG };
4228   eval { require Imager::File::SGI };
4229   eval { require Imager::File::TIFF };
4230   eval { require Imager::File::ICO };
4231   eval { require Imager::Font::W32 };
4232   eval { require Imager::Font::FT2 };
4233   eval { require Imager::Font::T1 };
4234 }
4235
4236 package Imager::IO;
4237 use IO::Seekable;
4238
4239 sub new_fh {
4240   my ($class, $fh) = @_;
4241
4242   if (tied(*$fh)) {
4243     return $class->new_cb
4244       (
4245        sub {
4246          local $\;
4247
4248          return print $fh $_[0];
4249        },
4250        sub {
4251          my $tmp;
4252          my $count = CORE::read $fh, $tmp, $_[1];
4253          defined $count
4254            or return undef;
4255          $count
4256            or return "";
4257          return $tmp;
4258        },
4259        sub {
4260          if ($_[1] != SEEK_CUR || $_[0] != 0) {
4261            unless (CORE::seek $fh, $_[0], $_[1]) {
4262              return -1;
4263            }
4264          }
4265
4266          return tell $fh;
4267        },
4268        undef,
4269       );
4270   }
4271   else {
4272     return $class->_new_perlio($fh);
4273   }
4274 }
4275
4276 # backward compatibility for %formats
4277 package Imager::FORMATS;
4278 use strict;
4279 use constant IX_FORMATS => 0;
4280 use constant IX_LIST => 1;
4281 use constant IX_INDEX => 2;
4282 use constant IX_CLASSES => 3;
4283
4284 sub TIEHASH {
4285   my ($class, $formats, $classes) = @_;
4286
4287   return bless [ $formats, [ ], 0, $classes ], $class;
4288 }
4289
4290 sub _check {
4291   my ($self, $key) = @_;
4292
4293   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4294   my $value;
4295   my $error;
4296   my $loaded = Imager::_load_file($file, \$error);
4297   if ($loaded) {
4298     $value = 1;
4299   }
4300   else {
4301     if ($error =~ /^Can't locate /) {
4302       $error = "Can't locate $file";
4303     }
4304     $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
4305     $value = undef;
4306   }
4307   $self->[IX_FORMATS]{$key} = $value;
4308
4309   return $value;
4310 }
4311
4312 sub FETCH {
4313   my ($self, $key) = @_;
4314
4315   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4316
4317   $self->[IX_CLASSES]{$key} or return undef;
4318
4319   return $self->_check($key);
4320 }
4321
4322 sub STORE {
4323   die "%Imager::formats is not user monifiable";
4324 }
4325
4326 sub DELETE {
4327   die "%Imager::formats is not user monifiable";
4328 }
4329
4330 sub CLEAR {
4331   die "%Imager::formats is not user monifiable";
4332 }
4333
4334 sub EXISTS {
4335   my ($self, $key) = @_;
4336
4337   if (exists $self->[IX_FORMATS]{$key}) {
4338     my $value = $self->[IX_FORMATS]{$key}
4339       or return;
4340     return 1;
4341   }
4342
4343   $self->_check($key) or return 1==0;
4344
4345   return 1==1;
4346 }
4347
4348 sub FIRSTKEY {
4349   my ($self) = @_;
4350
4351   unless (@{$self->[IX_LIST]}) {
4352     # full populate it
4353     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4354       keys %{$self->[IX_FORMATS]};
4355
4356     for my $key (keys %{$self->[IX_CLASSES]}) {
4357       $self->[IX_FORMATS]{$key} and next;
4358       $self->_check($key)
4359         and push @{$self->[IX_LIST]}, $key;
4360     }
4361   }
4362
4363   @{$self->[IX_LIST]} or return;
4364   $self->[IX_INDEX] = 1;
4365   return $self->[IX_LIST][0];
4366 }
4367
4368 sub NEXTKEY {
4369   my ($self) = @_;
4370
4371   $self->[IX_INDEX] < @{$self->[IX_LIST]}
4372     or return;
4373
4374   return $self->[IX_LIST][$self->[IX_INDEX]++];
4375 }
4376
4377 sub SCALAR {
4378   my ($self) = @_;
4379
4380   return scalar @{$self->[IX_LIST]};
4381 }
4382
4383 1;
4384 __END__
4385 # Below is the stub of documentation for your module. You better edit it!
4386
4387 =head1 NAME
4388
4389 Imager - Perl extension for Generating 24 bit Images
4390
4391 =head1 SYNOPSIS
4392
4393   # Thumbnail example
4394
4395   #!/usr/bin/perl -w
4396   use strict;
4397   use Imager;
4398
4399   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
4400   my $file = shift;
4401
4402   my $format;
4403
4404   # see Imager::Files for information on the read() method
4405   my $img = Imager->new(file=>$file)
4406     or die Imager->errstr();
4407
4408   $file =~ s/\.[^.]*$//;
4409
4410   # Create smaller version
4411   # documented in Imager::Transformations
4412   my $thumb = $img->scale(scalefactor=>.3);
4413
4414   # Autostretch individual channels
4415   $thumb->filter(type=>'autolevels');
4416
4417   # try to save in one of these formats
4418   SAVE:
4419
4420   for $format ( qw( png gif jpeg tiff ppm ) ) {
4421     # Check if given format is supported
4422     if ($Imager::formats{$format}) {
4423       $file.="_low.$format";
4424       print "Storing image as: $file\n";
4425       # documented in Imager::Files
4426       $thumb->write(file=>$file) or
4427         die $thumb->errstr;
4428       last SAVE;
4429     }
4430   }
4431
4432 =head1 DESCRIPTION
4433
4434 Imager is a module for creating and altering images.  It can read and
4435 write various image formats, draw primitive shapes like lines,and
4436 polygons, blend multiple images together in various ways, scale, crop,
4437 render text and more.
4438
4439 =head2 Overview of documentation
4440
4441 =over
4442
4443 =item *
4444
4445 Imager - This document - Synopsis, Example, Table of Contents and
4446 Overview.
4447
4448 =item *
4449
4450 L<Imager::Install> - installation notes for Imager.
4451
4452 =item *
4453
4454 L<Imager::Tutorial> - a brief introduction to Imager.
4455
4456 =item *
4457
4458 L<Imager::Cookbook> - how to do various things with Imager.
4459
4460 =item *
4461
4462 L<Imager::ImageTypes> - Basics of constructing image objects with
4463 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4464 8/16/double bits/channel, color maps, channel masks, image tags, color
4465 quantization.  Also discusses basic image information methods.
4466
4467 =item *
4468
4469 L<Imager::Files> - IO interaction, reading/writing images, format
4470 specific tags.
4471
4472 =item *
4473
4474 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4475 flood fill.
4476
4477 =item *
4478
4479 L<Imager::Color> - Color specification.
4480
4481 =item *
4482
4483 L<Imager::Fill> - Fill pattern specification.
4484
4485 =item *
4486
4487 L<Imager::Font> - General font rendering, bounding boxes and font
4488 metrics.
4489
4490 =item *
4491
4492 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4493 blending, pasting, convert and map.
4494
4495 =item *
4496
4497 L<Imager::Engines> - Programmable transformations through
4498 C<transform()>, C<transform2()> and C<matrix_transform()>.
4499
4500 =item *
4501
4502 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4503 filter plug-ins.
4504
4505 =item *
4506
4507 L<Imager::Expr> - Expressions for evaluation engine used by
4508 transform2().
4509
4510 =item *
4511
4512 L<Imager::Matrix2d> - Helper class for affine transformations.
4513
4514 =item *
4515
4516 L<Imager::Fountain> - Helper for making gradient profiles.
4517
4518 =item *
4519
4520 L<Imager::IO> - Imager I/O abstraction.
4521
4522 =item *
4523
4524 L<Imager::API> - using Imager's C API
4525
4526 =item *
4527
4528 L<Imager::APIRef> - API function reference
4529
4530 =item *
4531
4532 L<Imager::Inline> - using Imager's C API from Inline::C
4533
4534 =item *
4535
4536 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4537
4538 =item *
4539
4540 L<Imager::Security> - brief security notes.
4541
4542 =item *
4543
4544 L<Imager::Threads> - brief information on working with threads.
4545
4546 =back
4547
4548 =head2 Basic Overview
4549
4550 An Image object is created with C<$img = Imager-E<gt>new()>.
4551 Examples:
4552
4553   $img=Imager->new();                         # create empty image
4554   $img->read(file=>'lena.png',type=>'png') or # read image from file
4555      die $img->errstr();                      # give an explanation
4556                                               # if something failed
4557
4558 or if you want to create an empty image:
4559
4560   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4561
4562 This example creates a completely black image of width 400 and height
4563 300 and 4 channels.
4564
4565 =head1 ERROR HANDLING
4566
4567 In general a method will return false when it fails, if it does use
4568 the C<errstr()> method to find out why:
4569
4570 =over
4571
4572 =item errstr()
4573
4574 Returns the last error message in that context.
4575
4576 If the last error you received was from calling an object method, such
4577 as read, call errstr() as an object method to find out why:
4578
4579   my $image = Imager->new;
4580   $image->read(file => 'somefile.gif')
4581      or die $image->errstr;
4582
4583 If it was a class method then call errstr() as a class method:
4584
4585   my @imgs = Imager->read_multi(file => 'somefile.gif')
4586     or die Imager->errstr;
4587
4588 Note that in some cases object methods are implemented in terms of
4589 class methods so a failing object method may set both.
4590
4591 =back
4592
4593 The C<Imager-E<gt>new> method is described in detail in
4594 L<Imager::ImageTypes>.
4595
4596 =head1 METHOD INDEX
4597
4598 Where to find information on methods for Imager class objects.
4599
4600 addcolors() - L<Imager::ImageTypes/addcolors()> - add colors to a
4601 paletted image
4602
4603 addtag() -  L<Imager::ImageTypes/addtag()> - add image tags
4604
4605 align_string() - L<Imager::Draw/align_string()> - draw text aligned on a
4606 point
4607
4608 arc() - L<Imager::Draw/arc()> - draw a filled arc
4609
4610 bits() - L<Imager::ImageTypes/bits()> - number of bits per sample for the
4611 image
4612
4613 box() - L<Imager::Draw/box()> - draw a filled or outline box.
4614
4615 check_file_limits() - L<Imager::Files/check_file_limits()>
4616
4617 circle() - L<Imager::Draw/circle()> - draw a filled circle
4618
4619 close_log() - L<Imager::ImageTypes/close_log()> - close the Imager
4620 debugging log.
4621
4622 colorcount() - L<Imager::ImageTypes/colorcount()> - the number of
4623 colors in an image's palette (paletted images only)
4624
4625 combine() - L<Imager::Transformations/combine()> - combine channels
4626 from one or more images.
4627
4628 combines() - L<Imager::Draw/combines()> - return a list of the
4629 different combine type keywords
4630
4631 compose() - L<Imager::Transformations/compose()> - compose one image
4632 over another.
4633
4634 convert() - L<Imager::Transformations/convert()> - transform the color
4635 space
4636
4637 copy() - L<Imager::Transformations/copy()> - make a duplicate of an
4638 image
4639
4640 crop() - L<Imager::Transformations/crop()> - extract part of an image
4641
4642 def_guess_type() - L<Imager::Files/def_guess_type()> - default function
4643 used to guess the output file format based on the output file name
4644
4645 deltag() -  L<Imager::ImageTypes/deltag()> - delete image tags
4646
4647 difference() - L<Imager::Filters/difference()> - produce a difference
4648 images from two input images.
4649
4650 errstr() - L</errstr()> - the error from the last failed operation.
4651
4652 filter() - L<Imager::Filters/filter()> - image filtering
4653
4654 findcolor() - L<Imager::ImageTypes/findcolor()> - search the image
4655 palette, if it has one
4656
4657 flip() - L<Imager::Transformations/flip()> - flip an image, vertically,
4658 horizontally
4659
4660 flood_fill() - L<Imager::Draw/flood_fill()> - fill an enclosed or same
4661 color area
4662
4663 getchannels() - L<Imager::ImageTypes/getchannels()> - the number of
4664 samples per pixel for an image
4665
4666 getcolorcount() - L<Imager::ImageTypes/getcolorcount()> - the number of
4667 different colors used by an image (works for direct color images)
4668
4669 getcolors() - L<Imager::ImageTypes/getcolors()> - get colors from the image
4670 palette, if it has one
4671
4672 getcolorusage() - L<Imager::ImageTypes/getcolorusage()>
4673
4674 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash()>
4675
4676 get_file_limits() - L<Imager::Files/get_file_limits()>
4677
4678 getheight() - L<Imager::ImageTypes/getheight()> - height of the image in
4679 pixels
4680
4681 getmask() - L<Imager::ImageTypes/getmask()> - write mask for the image
4682
4683 getpixel() - L<Imager::Draw/getpixel()> - retrieve one or more pixel
4684 colors
4685
4686 getsamples() - L<Imager::Draw/getsamples()> - retrieve samples from a
4687 row or partial row of pixels.
4688
4689 getscanline() - L<Imager::Draw/getscanline()> - retrieve colors for a
4690 row or partial row of pixels.
4691
4692 getwidth() - L<Imager::ImageTypes/getwidth()> - width of the image in
4693 pixels.
4694
4695 img_set() - L<Imager::ImageTypes/img_set()> - re-use an Imager object
4696 for a new image.
4697
4698 init() - L<Imager::ImageTypes/init()>
4699
4700 is_bilevel() - L<Imager::ImageTypes/is_bilevel()> - returns whether
4701 image write functions should write the image in their bilevel (blank
4702 and white, no gray levels) format
4703
4704 is_logging() L<Imager::ImageTypes/is_logging()> - test if the debug
4705 log is active.
4706
4707 line() - L<Imager::Draw/line()> - draw an interval
4708
4709 load_plugin() - L<Imager::Filters/load_plugin()>
4710
4711 log() - L<Imager::ImageTypes/log()> - send a message to the debugging
4712 log.
4713
4714 make_palette() - L<Imager::ImageTypes/make_palette()> - produce a
4715 color palette from one or more input images.
4716
4717 map() - L<Imager::Transformations/map()> - remap color
4718 channel values
4719
4720 masked() -  L<Imager::ImageTypes/masked()> - make a masked image
4721
4722 matrix_transform() - L<Imager::Engines/matrix_transform()>
4723
4724 maxcolors() - L<Imager::ImageTypes/maxcolors()>
4725
4726 NC() - L<Imager::Handy/NC()>
4727
4728 NCF() - L<Imager::Handy/NCF()>
4729
4730 new() - L<Imager::ImageTypes/new()>
4731
4732 newcolor() - L<Imager::Handy/newcolor()>
4733
4734 newcolour() - L<Imager::Handy/newcolour()>
4735
4736 newfont() - L<Imager::Handy/newfont()>
4737
4738 NF() - L<Imager::Handy/NF()>
4739
4740 open() - L<Imager::Files/read()> - an alias for read()
4741
4742 open_log() - L<Imager::ImageTypes/open_log()> - open the debug log.
4743
4744 =for stopwords IPTC
4745
4746 parseiptc() - L<Imager::Files/parseiptc()> - parse IPTC data from a JPEG
4747 image
4748
4749 paste() - L<Imager::Transformations/paste()> - draw an image onto an
4750 image
4751
4752 polygon() - L<Imager::Draw/polygon()>
4753
4754 polyline() - L<Imager::Draw/polyline()>
4755
4756 preload() - L<Imager::Files/preload()>
4757
4758 read() - L<Imager::Files/read()> - read a single image from an image file
4759
4760 read_multi() - L<Imager::Files/read_multi()> - read multiple images from an image
4761 file
4762
4763 read_types() - L<Imager::Files/read_types()> - list image types Imager
4764 can read.
4765
4766 register_filter() - L<Imager::Filters/register_filter()>
4767
4768 register_reader() - L<Imager::Files/register_reader()>
4769
4770 register_writer() - L<Imager::Files/register_writer()>
4771
4772 rotate() - L<Imager::Transformations/rotate()>
4773
4774 rubthrough() - L<Imager::Transformations/rubthrough()> - draw an image
4775 onto an image and use the alpha channel
4776
4777 scale() - L<Imager::Transformations/scale()>
4778
4779 scale_calculate() - L<Imager::Transformations/scale_calculate()>
4780
4781 scaleX() - L<Imager::Transformations/scaleX()>
4782
4783 scaleY() - L<Imager::Transformations/scaleY()>
4784
4785 setcolors() - L<Imager::ImageTypes/setcolors()> - set palette colors
4786 in a paletted image
4787
4788 set_file_limits() - L<Imager::Files/set_file_limits()>
4789
4790 setmask() - L<Imager::ImageTypes/setmask()>
4791
4792 setpixel() - L<Imager::Draw/setpixel()>
4793
4794 setsamples() - L<Imager::Draw/setsamples()>
4795
4796 setscanline() - L<Imager::Draw/setscanline()>
4797
4798 settag() - L<Imager::ImageTypes/settag()>
4799
4800 string() - L<Imager::Draw/string()> - draw text on an image
4801
4802 tags() -  L<Imager::ImageTypes/tags()> - fetch image tags
4803
4804 to_paletted() -  L<Imager::ImageTypes/to_paletted()>
4805
4806 to_rgb16() - L<Imager::ImageTypes/to_rgb16()>
4807
4808 to_rgb8() - L<Imager::ImageTypes/to_rgb8()>
4809
4810 to_rgb_double() - L<Imager::ImageTypes/to_rgb_double()> - convert to
4811 double per sample image.
4812
4813 transform() - L<Imager::Engines/"transform()">
4814
4815 transform2() - L<Imager::Engines/"transform2()">
4816
4817 type() -  L<Imager::ImageTypes/type()> - type of image (direct vs paletted)
4818
4819 unload_plugin() - L<Imager::Filters/unload_plugin()>
4820
4821 virtual() - L<Imager::ImageTypes/virtual()> - whether the image has it's own
4822 data
4823
4824 write() - L<Imager::Files/write()> - write an image to a file
4825
4826 write_multi() - L<Imager::Files/write_multi()> - write multiple image to an image
4827 file.
4828
4829 write_types() - L<Imager::Files/read_types()> - list image types Imager
4830 can write.
4831
4832 =head1 CONCEPT INDEX
4833
4834 animated GIF - L<Imager::Files/"Writing an animated GIF">
4835
4836 aspect ratio - C<i_xres>, C<i_yres>, C<i_aspect_only> in
4837 L<Imager::ImageTypes/"Common Tags">.
4838
4839 blend - alpha blending one image onto another
4840 L<Imager::Transformations/rubthrough()>
4841
4842 blur - L<Imager::Filters/gaussian>, L<Imager::Filters/conv>
4843
4844 boxes, drawing - L<Imager::Draw/box()>
4845
4846 changes between image - L<Imager::Filters/"Image Difference">
4847
4848 channels, combine into one image - L<Imager::Transformations/combine()>
4849
4850 color - L<Imager::Color>
4851
4852 color names - L<Imager::Color>, L<Imager::Color::Table>
4853
4854 combine modes - L<Imager::Draw/"Combine Types">
4855
4856 compare images - L<Imager::Filters/"Image Difference">
4857
4858 contrast - L<Imager::Filters/contrast>, L<Imager::Filters/autolevels>
4859
4860 convolution - L<Imager::Filters/conv>
4861
4862 cropping - L<Imager::Transformations/crop()>
4863
4864 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4865
4866 C<diff> images - L<Imager::Filters/"Image Difference">
4867
4868 dpi - C<i_xres>, C<i_yres> in L<Imager::ImageTypes/"Common Tags">,
4869 L<Imager::Cookbook/"Image spatial resolution">
4870
4871 drawing boxes - L<Imager::Draw/box()>
4872
4873 drawing lines - L<Imager::Draw/line()>
4874
4875 drawing text - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>
4876
4877 error message - L</"ERROR HANDLING">
4878
4879 files, font - L<Imager::Font>
4880
4881 files, image - L<Imager::Files>
4882
4883 filling, types of fill - L<Imager::Fill>
4884
4885 filling, boxes - L<Imager::Draw/box()>
4886
4887 filling, flood fill - L<Imager::Draw/flood_fill()>
4888
4889 flood fill - L<Imager::Draw/flood_fill()>
4890
4891 fonts - L<Imager::Font>
4892
4893 fonts, drawing with - L<Imager::Draw/string()>,
4894 L<Imager::Draw/align_string()>, L<Imager::Font::Wrap>
4895
4896 fonts, metrics - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4897
4898 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4899
4900 fountain fill - L<Imager::Fill/"Fountain fills">,
4901 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4902 L<Imager::Filters/gradgen>
4903
4904 GIF files - L<Imager::Files/"GIF">
4905
4906 GIF files, animated - L<Imager::Files/"Writing an animated GIF">
4907
4908 gradient fill - L<Imager::Fill/"Fountain fills">,
4909 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4910 L<Imager::Filters/gradgen>
4911
4912 gray scale, convert image to - L<Imager::Transformations/convert()>
4913
4914 gaussian blur - L<Imager::Filters/gaussian>
4915
4916 hatch fills - L<Imager::Fill/"Hatched fills">
4917
4918 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4919
4920 invert image - L<Imager::Filters/hardinvert>,
4921 L<Imager::Filters/hardinvertall>
4922
4923 JPEG - L<Imager::Files/"JPEG">
4924
4925 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4926
4927 lines, drawing - L<Imager::Draw/line()>
4928
4929 matrix - L<Imager::Matrix2d>,
4930 L<Imager::Engines/"Matrix Transformations">,
4931 L<Imager::Font/transform()>
4932
4933 metadata, image - L<Imager::ImageTypes/"Tags">, L<Image::ExifTool>
4934
4935 mosaic - L<Imager::Filters/mosaic>
4936
4937 noise, filter - L<Imager::Filters/noise>
4938
4939 noise, rendered - L<Imager::Filters/turbnoise>,
4940 L<Imager::Filters/radnoise>
4941
4942 paste - L<Imager::Transformations/paste()>,
4943 L<Imager::Transformations/rubthrough()>
4944
4945 pseudo-color image - L<Imager::ImageTypes/to_paletted()>,
4946 L<Imager::ImageTypes/new()>
4947
4948 =for stopwords posterize
4949
4950 posterize - L<Imager::Filters/postlevels>
4951
4952 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
4953
4954 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
4955
4956 rectangles, drawing - L<Imager::Draw/box()>
4957
4958 resizing an image - L<Imager::Transformations/scale()>,
4959 L<Imager::Transformations/crop()>
4960
4961 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4962
4963 saving an image - L<Imager::Files>
4964
4965 scaling - L<Imager::Transformations/scale()>
4966
4967 security - L<Imager::Security>
4968
4969 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4970
4971 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4972
4973 size, image - L<Imager::ImageTypes/getwidth()>,
4974 L<Imager::ImageTypes/getheight()>
4975
4976 size, text - L<Imager::Font/bounding_box()>
4977
4978 tags, image metadata - L<Imager::ImageTypes/"Tags">
4979
4980 text, drawing - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>,
4981 L<Imager::Font::Wrap>
4982
4983 text, wrapping text in an area - L<Imager::Font::Wrap>
4984
4985 text, measuring - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4986
4987 threads - L<Imager::Threads>
4988
4989 tiles, color - L<Imager::Filters/mosaic>
4990
4991 transparent images - L<Imager::ImageTypes>,
4992 L<Imager::Cookbook/"Transparent PNG">
4993
4994 =for stopwords unsharp
4995
4996 unsharp mask - L<Imager::Filters/unsharpmask>
4997
4998 watermark - L<Imager::Filters/watermark>
4999
5000 writing an image to a file - L<Imager::Files>
5001
5002 =head1 SUPPORT
5003
5004 The best place to get help with Imager is the mailing list.
5005
5006 To subscribe send a message with C<subscribe> in the body to:
5007
5008    imager-devel+request@molar.is
5009
5010 or use the form at:
5011
5012 =over
5013
5014 L<http://www.molar.is/en/lists/imager-devel/>
5015
5016 =back
5017
5018 where you can also find the mailing list archive.
5019
5020 You can report bugs by pointing your browser at:
5021
5022 =over
5023
5024 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
5025
5026 =back
5027
5028 or by sending an email to:
5029
5030 =over
5031
5032 bug-Imager@rt.cpan.org
5033
5034 =back
5035
5036 Please remember to include the versions of Imager, perl, supporting
5037 libraries, and any relevant code.  If you have specific images that
5038 cause the problems, please include those too.
5039
5040 If you don't want to publish your email address on a mailing list you
5041 can use CPAN::Forum:
5042
5043   http://www.cpanforum.com/dist/Imager
5044
5045 You will need to register to post.
5046
5047 =head1 CONTRIBUTING TO IMAGER
5048
5049 =head2 Feedback
5050
5051 I like feedback.
5052
5053 If you like or dislike Imager, you can add a public review of Imager
5054 at CPAN Ratings:
5055
5056   http://cpanratings.perl.org/dist/Imager
5057
5058 =for stopwords Bitcard
5059
5060 This requires a Bitcard account (http://www.bitcard.org).
5061
5062 You can also send email to the maintainer below.
5063
5064 If you send me a bug report via email, it will be copied to Request
5065 Tracker.
5066
5067 =head2 Patches
5068
5069 I accept patches, preferably against the master branch in git.  Please
5070 include an explanation of the reason for why the patch is needed or
5071 useful.
5072
5073 Your patch should include regression tests where possible, otherwise
5074 it will be delayed until I get a chance to write them.
5075
5076 To browse Imager's git repository:
5077
5078   http://git.imager.perl.org/imager.git
5079
5080 To clone:
5081
5082   git clone git://git.imager.perl.org/imager.git
5083
5084 My preference is that patches are provided in the format produced by
5085 C<git format-patch>, for example, if you made your changes in a branch
5086 from master you might do:
5087
5088   git format-patch -k --stdout master >my-patch.txt
5089
5090 and then attach that to your bug report, either by adding it as an
5091 attachment in your email client, or by using the Request Tracker
5092 attachment mechanism.
5093
5094 =head1 AUTHOR
5095
5096 Tony Cook <tonyc@cpan.org> is the current maintainer for Imager.
5097
5098 Arnar M. Hrafnkelsson is the original author of Imager.
5099
5100 Many others have contributed to Imager, please see the C<README> for a
5101 complete list.
5102
5103 =head1 LICENSE
5104
5105 Imager is licensed under the same terms as perl itself.
5106
5107 =for stopwords
5108 makeblendedfont Fontforge
5109
5110 A test font, generated by the Debian packaged Fontforge,
5111 F<FT2/fontfiles/MMOne.pfb>, contains a Postscript operator definition
5112 copyrighted by Adobe.  See F<adobe.txt> in the source for license
5113 information.
5114
5115 =head1 SEE ALSO
5116
5117 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
5118 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
5119 L<Imager::Font>(3), L<Imager::Transformations>(3),
5120 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
5121 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
5122
5123 L<http://imager.perl.org/>
5124
5125 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
5126
5127 Other perl imaging modules include:
5128
5129 L<GD>(3), L<Image::Magick>(3),
5130 L<Graphics::Magick|http://www.graphicsmagick.org/perl.html>(3),
5131 L<Prima::Image>, L<IPA>.
5132
5133 For manipulating image metadata see L<Image::ExifTool>.
5134
5135 If you're trying to use Imager for array processing, you should
5136 probably using L<PDL>.
5137
5138 =cut