Imager.pm

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