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