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