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