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