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.89';
 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}=Imager::ImgRaw::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 loading $file";
1609       chomp $work;
1610       $work =~ s/\n?Compilation failed in require at .*Imager\.pm line .*\z//m;
1611       $work =~ s/\n/\\n/g;
1612       $file_load_errors{$file} = $work;
1613       $$error = $work;
1614       return 0;
1615     }
1616   }
1617 }
1618
1619 # probes for an Imager::File::whatever module
1620 sub _reader_autoload {
1621   my $type = shift;
1622
1623   return if $formats_low{$type} || $readers{$type};
1624
1625   return unless $type =~ /^\w+$/;
1626
1627   my $file = "Imager/File/\U$type\E.pm";
1628
1629   my $error;
1630   my $loaded = _load_file($file, \$error);
1631   if (!$loaded && $error =~ /^Can't locate /) {
1632     my $filer = "Imager/File/\U$type\EReader.pm";
1633     $loaded = _load_file($filer, \$error);
1634     if ($error =~ /^Can't locate /) {
1635       $error = "Can't locate $file or $filer";
1636     }
1637   }
1638   unless ($loaded) {
1639     $reader_load_errors{$type} = $error;
1640   }
1641 }
1642
1643 # probes for an Imager::File::whatever module
1644 sub _writer_autoload {
1645   my $type = shift;
1646
1647   return if $formats_low{$type} || $writers{$type};
1648
1649   return unless $type =~ /^\w+$/;
1650
1651   my $file = "Imager/File/\U$type\E.pm";
1652
1653   my $error;
1654   my $loaded = _load_file($file, \$error);
1655   if (!$loaded && $error =~ /^Can't locate /) {
1656     my $filew = "Imager/File/\U$type\EWriter.pm";
1657     $loaded = _load_file($filew, \$error);
1658     if ($error =~ /^Can't locate /) {
1659       $error = "Can't locate $file or $filew";
1660     }
1661   }
1662   unless ($loaded) {
1663     $writer_load_errors{$type} = $error;
1664   }
1665 }
1666
1667 sub _fix_gif_positions {
1668   my ($opts, $opt, $msg, @imgs) = @_;
1669
1670   my $positions = $opts->{'gif_positions'};
1671   my $index = 0;
1672   for my $pos (@$positions) {
1673     my ($x, $y) = @$pos;
1674     my $img = $imgs[$index++];
1675     $img->settag(name=>'gif_left', value=>$x);
1676     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1677   }
1678   $$msg .= "replaced with the gif_left and gif_top tags";
1679 }
1680
1681 my %obsolete_opts =
1682   (
1683    gif_each_palette=>'gif_local_map',
1684    interlace       => 'gif_interlace',
1685    gif_delays => 'gif_delay',
1686    gif_positions => \&_fix_gif_positions,
1687    gif_loop_count => 'gif_loop',
1688   );
1689
1690 # options that should be converted to colors
1691 my %color_opts = map { $_ => 1 } qw/i_background/;
1692
1693 sub _set_opts {
1694   my ($self, $opts, $prefix, @imgs) = @_;
1695
1696   for my $opt (keys %$opts) {
1697     my $tagname = $opt;
1698     if ($obsolete_opts{$opt}) {
1699       my $new = $obsolete_opts{$opt};
1700       my $msg = "Obsolete option $opt ";
1701       if (ref $new) {
1702         $new->($opts, $opt, \$msg, @imgs);
1703       }
1704       else {
1705         $msg .= "replaced with the $new tag ";
1706         $tagname = $new;
1707       }
1708       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1709       warn $msg if $warn_obsolete && $^W;
1710     }
1711     next unless $tagname =~ /^\Q$prefix/;
1712     my $value = $opts->{$opt};
1713     if ($color_opts{$opt}) {
1714       $value = _color($value);
1715       unless ($value) {
1716         $self->_set_error($Imager::ERRSTR);
1717         return;
1718       }
1719     }
1720     if (ref $value) {
1721       if (UNIVERSAL::isa($value, "Imager::Color")) {
1722         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1723         for my $img (@imgs) {
1724           $img->settag(name=>$tagname, value=>$tag);
1725         }
1726       }
1727       elsif (ref($value) eq 'ARRAY') {
1728         for my $i (0..$#$value) {
1729           my $val = $value->[$i];
1730           if (ref $val) {
1731             if (UNIVERSAL::isa($val, "Imager::Color")) {
1732               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1733               $i < @imgs and
1734                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1735             }
1736             else {
1737               $self->_set_error("Unknown reference type " . ref($value) .
1738                                 " supplied in array for $opt");
1739               return;
1740             }
1741           }
1742           else {
1743             $i < @imgs
1744               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1745           }
1746         }
1747       }
1748       else {
1749         $self->_set_error("Unknown reference type " . ref($value) .
1750                           " supplied for $opt");
1751         return;
1752       }
1753     }
1754     else {
1755       # set it as a tag for every image
1756       for my $img (@imgs) {
1757         $img->settag(name=>$tagname, value=>$value);
1758       }
1759     }
1760   }
1761
1762   return 1;
1763 }
1764
1765 # Write an image to file
1766 sub write {
1767   my $self = shift;
1768   my %input=(jpegquality=>75,
1769              gifquant=>'mc',
1770              lmdither=>6.0,
1771              lmfixed=>[],
1772              idstring=>"",
1773              compress=>1,
1774              wierdpack=>0,
1775              fax_fine=>1, @_);
1776   my $rc;
1777
1778   $self->_set_opts(\%input, "i_", $self)
1779     or return undef;
1780
1781   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1782
1783   my $type = $input{'type'};
1784   if (!$type and $input{file}) {
1785     $type = $FORMATGUESS->($input{file});
1786   }
1787   unless ($type) {
1788     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1789     return undef;
1790   }
1791
1792   _writer_autoload($type);
1793
1794   my ($IO, $fh);
1795   if ($writers{$type} && $writers{$type}{single}) {
1796     ($IO, $fh) = $self->_get_writer_io(\%input)
1797       or return undef;
1798
1799     $writers{$type}{single}->($self, $IO, %input, type => $type)
1800       or return undef;
1801   }
1802   else {
1803     if (!$formats_low{$type}) {
1804       my $write_types = join ', ', sort Imager->write_types();
1805       $self->_set_error("format '$type' not supported - formats $write_types available for writing - $writer_load_errors{$type}");
1806       return undef;
1807     }
1808
1809     ($IO, $fh) = $self->_get_writer_io(\%input, $type)
1810       or return undef;
1811
1812     if ( $type eq 'pnm' ) {
1813       $self->_set_opts(\%input, "pnm_", $self)
1814         or return undef;
1815       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1816         $self->{ERRSTR} = $self->_error_as_msg();
1817         return undef;
1818       }
1819       $self->{DEBUG} && print "writing a pnm file\n";
1820     }
1821     elsif ( $type eq 'raw' ) {
1822       $self->_set_opts(\%input, "raw_", $self)
1823         or return undef;
1824       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1825         $self->{ERRSTR} = $self->_error_as_msg();
1826         return undef;
1827       }
1828       $self->{DEBUG} && print "writing a raw file\n";
1829     }
1830     elsif ( $type eq 'bmp' ) {
1831       $self->_set_opts(\%input, "bmp_", $self)
1832         or return undef;
1833       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1834         $self->{ERRSTR} = $self->_error_as_msg;
1835         return undef;
1836       }
1837       $self->{DEBUG} && print "writing a bmp file\n";
1838     }
1839     elsif ( $type eq 'tga' ) {
1840       $self->_set_opts(\%input, "tga_", $self)
1841         or return undef;
1842
1843       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1844         $self->{ERRSTR}=$self->_error_as_msg();
1845         return undef;
1846       }
1847       $self->{DEBUG} && print "writing a tga file\n";
1848     }
1849   }
1850
1851   if (exists $input{'data'}) {
1852     my $data = io_slurp($IO);
1853     if (!$data) {
1854       $self->{ERRSTR}='Could not slurp from buffer';
1855       return undef;
1856     }
1857     ${$input{data}} = $data;
1858   }
1859   return $self;
1860 }
1861
1862 sub write_multi {
1863   my ($class, $opts, @images) = @_;
1864
1865   my $type = $opts->{type};
1866
1867   if (!$type && $opts->{'file'}) {
1868     $type = $FORMATGUESS->($opts->{'file'});
1869   }
1870   unless ($type) {
1871     $class->_set_error('type parameter missing and not possible to guess from extension');
1872     return;
1873   }
1874   # translate to ImgRaw
1875   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1876     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1877     return 0;
1878   }
1879   $class->_set_opts($opts, "i_", @images)
1880     or return;
1881   my @work = map $_->{IMG}, @images;
1882
1883   _writer_autoload($type);
1884
1885   my ($IO, $file);
1886   if ($writers{$type} && $writers{$type}{multiple}) {
1887     ($IO, $file) = $class->_get_writer_io($opts, $type)
1888       or return undef;
1889
1890     $writers{$type}{multiple}->($class, $IO, $opts, @images)
1891       or return undef;
1892   }
1893   else {
1894     if (!$formats{$type}) {
1895       my $write_types = join ', ', sort Imager->write_types();
1896       $class->_set_error("format '$type' not supported - formats $write_types available for writing");
1897       return undef;
1898     }
1899
1900     ($IO, $file) = $class->_get_writer_io($opts, $type)
1901       or return undef;
1902
1903     if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
1904     }
1905     else {
1906       if (@images == 1) {
1907         unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1908           return 1;
1909         }
1910       }
1911       else {
1912         $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1913         return 0;
1914       }
1915     }
1916   }
1917
1918   if (exists $opts->{'data'}) {
1919     my $data = io_slurp($IO);
1920     if (!$data) {
1921       Imager->_set_error('Could not slurp from buffer');
1922       return undef;
1923     }
1924     ${$opts->{data}} = $data;
1925   }
1926   return 1;
1927 }
1928
1929 # read multiple images from a file
1930 sub read_multi {
1931   my ($class, %opts) = @_;
1932
1933   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1934     or return;
1935
1936   my $type = $opts{'type'};
1937   unless ($type) {
1938     $type = i_test_format_probe($IO, -1);
1939   }
1940
1941   if ($opts{file} && !$type) {
1942     # guess the type
1943     $type = $FORMATGUESS->($opts{file});
1944   }
1945
1946   unless ($type) {
1947     my $msg = "type parameter missing and it couldn't be determined from the file contents";
1948     $opts{file} and $msg .= " or file name";
1949     Imager->_set_error($msg);
1950     return;
1951   }
1952
1953   _reader_autoload($type);
1954
1955   if ($readers{$type} && $readers{$type}{multiple}) {
1956     return $readers{$type}{multiple}->($IO, %opts);
1957   }
1958
1959   unless ($formats{$type}) {
1960     my $read_types = join ', ', sort Imager->read_types();
1961     Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
1962     return;
1963   }
1964
1965   my @imgs;
1966   if ($type eq 'pnm') {
1967     @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
1968   }
1969   else {
1970     my $img = Imager->new;
1971     if ($img->read(%opts, io => $IO, type => $type)) {
1972       return ( $img );
1973     }
1974     Imager->_set_error($img->errstr);
1975     return;
1976   }
1977
1978   if (!@imgs) {
1979     $ERRSTR = _error_as_msg();
1980   return;
1981   }
1982   return map {
1983         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1984       } @imgs;
1985 }
1986
1987 # Destroy an Imager object
1988
1989 sub DESTROY {
1990   my $self=shift;
1991   #    delete $instances{$self};
1992   if (defined($self->{IMG})) {
1993     # the following is now handled by the XS DESTROY method for
1994     # Imager::ImgRaw object
1995     # Re-enabling this will break virtual images
1996     # tested for in t/t020masked.t
1997     # i_img_destroy($self->{IMG});
1998     undef($self->{IMG});
1999   } else {
2000 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
2001   }
2002 }
2003
2004 # Perform an inplace filter of an image
2005 # that is the image will be overwritten with the data
2006
2007 sub filter {
2008   my $self=shift;
2009   my %input=@_;
2010   my %hsh;
2011   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2012
2013   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
2014
2015   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
2016     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2017   }
2018
2019   if ($filters{$input{'type'}}{names}) {
2020     my $names = $filters{$input{'type'}}{names};
2021     for my $name (keys %$names) {
2022       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2023         $input{$name} = $names->{$name}{$input{$name}};
2024       }
2025     }
2026   }
2027   if (defined($filters{$input{'type'}}{defaults})) {
2028     %hsh=( image => $self->{IMG},
2029            imager => $self,
2030            %{$filters{$input{'type'}}{defaults}},
2031            %input );
2032   } else {
2033     %hsh=( image => $self->{IMG},
2034            imager => $self,
2035            %input );
2036   }
2037
2038   my @cs=@{$filters{$input{'type'}}{callseq}};
2039
2040   for(@cs) {
2041     if (!defined($hsh{$_})) {
2042       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
2043     }
2044   }
2045
2046   eval {
2047     local $SIG{__DIE__}; # we don't want this processed by confess, etc
2048     &{$filters{$input{'type'}}{callsub}}(%hsh);
2049   };
2050   if ($@) {
2051     chomp($self->{ERRSTR} = $@);
2052     return;
2053   }
2054
2055   my @b=keys %hsh;
2056
2057   $self->{DEBUG} && print "callseq is: @cs\n";
2058   $self->{DEBUG} && print "matching callseq is: @b\n";
2059
2060   return $self;
2061 }
2062
2063 sub register_filter {
2064   my $class = shift;
2065   my %hsh = ( defaults => {}, @_ );
2066
2067   defined $hsh{type}
2068     or die "register_filter() with no type\n";
2069   defined $hsh{callsub}
2070     or die "register_filter() with no callsub\n";
2071   defined $hsh{callseq}
2072     or die "register_filter() with no callseq\n";
2073
2074   exists $filters{$hsh{type}}
2075     and return;
2076
2077   $filters{$hsh{type}} = \%hsh;
2078
2079   return 1;
2080 }
2081
2082 sub scale_calculate {
2083   my $self = shift;
2084
2085   my %opts = ('type'=>'max', @_);
2086
2087   # none of these should be references
2088   for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2089     if (defined $opts{$name} && ref $opts{$name}) {
2090       $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2091       return;
2092     }
2093   }
2094
2095   my ($x_scale, $y_scale);
2096   my $width = $opts{width};
2097   my $height = $opts{height};
2098   if (ref $self) {
2099     defined $width or $width = $self->getwidth;
2100     defined $height or $height = $self->getheight;
2101   }
2102   else {
2103     unless (defined $width && defined $height) {
2104       $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2105       return;
2106     }
2107   }
2108
2109   if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2110     $x_scale = $opts{'xscalefactor'};
2111     $y_scale = $opts{'yscalefactor'};
2112   }
2113   elsif ($opts{'xscalefactor'}) {
2114     $x_scale = $opts{'xscalefactor'};
2115     $y_scale = $opts{'scalefactor'} || $x_scale;
2116   }
2117   elsif ($opts{'yscalefactor'}) {
2118     $y_scale = $opts{'yscalefactor'};
2119     $x_scale = $opts{'scalefactor'} || $y_scale;
2120   }
2121   else {
2122     $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2123   }
2124
2125   # work out the scaling
2126   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
2127     my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2128                         $opts{ypixels} / $height );
2129     if ($opts{'type'} eq 'min') {
2130       $x_scale = $y_scale = _min($xpix,$ypix);
2131     }
2132     elsif ($opts{'type'} eq 'max') {
2133       $x_scale = $y_scale = _max($xpix,$ypix);
2134     }
2135     elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2136       $x_scale = $xpix;
2137       $y_scale = $ypix;
2138     }
2139     else {
2140       $self->_set_error('invalid value for type parameter');
2141       return;
2142     }
2143   } elsif ($opts{xpixels}) {
2144     $x_scale = $y_scale = $opts{xpixels} / $width;
2145   }
2146   elsif ($opts{ypixels}) {
2147     $x_scale = $y_scale = $opts{ypixels}/$height;
2148   }
2149   elsif ($opts{constrain} && ref $opts{constrain}
2150          && $opts{constrain}->can('constrain')) {
2151     # we've been passed an Image::Math::Constrain object or something
2152     # that looks like one
2153     my $scalefactor;
2154     (undef, undef, $scalefactor)
2155       = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2156     unless ($scalefactor) {
2157       $self->_set_error('constrain method failed on constrain parameter');
2158       return;
2159     }
2160     $x_scale = $y_scale = $scalefactor;
2161   }
2162
2163   my $new_width = int($x_scale * $width + 0.5);
2164   $new_width > 0 or $new_width = 1;
2165   my $new_height = int($y_scale * $height + 0.5);
2166   $new_height > 0 or $new_height = 1;
2167
2168   return ($x_scale, $y_scale, $new_width, $new_height);
2169
2170 }
2171
2172 # Scale an image to requested size and return the scaled version
2173
2174 sub scale {
2175   my $self=shift;
2176   my %opts = (qtype=>'normal' ,@_);
2177   my $img = Imager->new();
2178   my $tmp = Imager->new();
2179
2180   unless (defined wantarray) {
2181     my @caller = caller;
2182     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2183     return;
2184   }
2185
2186   unless ($self->{IMG}) {
2187     $self->_set_error('empty input image');
2188     return undef;
2189   }
2190
2191   my ($x_scale, $y_scale, $new_width, $new_height) =
2192     $self->scale_calculate(%opts)
2193       or return;
2194
2195   if ($opts{qtype} eq 'normal') {
2196     $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2197     if ( !defined($tmp->{IMG}) ) {
2198       $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
2199       return undef;
2200     }
2201     $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2202     if ( !defined($img->{IMG}) ) {
2203       $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
2204       return undef;
2205     }
2206
2207     return $img;
2208   }
2209   elsif ($opts{'qtype'} eq 'preview') {
2210     $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
2211     if ( !defined($img->{IMG}) ) {
2212       $self->{ERRSTR}='unable to scale image';
2213       return undef;
2214     }
2215     return $img;
2216   }
2217   elsif ($opts{'qtype'} eq 'mixing') {
2218     $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2219     unless ($img->{IMG}) {
2220       $self->_set_error(Imager->_error_as_msg);
2221       return;
2222     }
2223     return $img;
2224   }
2225   else {
2226     $self->_set_error('invalid value for qtype parameter');
2227     return undef;
2228   }
2229 }
2230
2231 # Scales only along the X axis
2232
2233 sub scaleX {
2234   my $self = shift;
2235   my %opts = ( scalefactor=>0.5, @_ );
2236
2237   unless (defined wantarray) {
2238     my @caller = caller;
2239     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2240     return;
2241   }
2242
2243   unless ($self->{IMG}) {
2244     $self->{ERRSTR} = 'empty input image';
2245     return undef;
2246   }
2247
2248   my $img = Imager->new();
2249
2250   my $scalefactor = $opts{scalefactor};
2251
2252   if ($opts{pixels}) {
2253     $scalefactor = $opts{pixels} / $self->getwidth();
2254   }
2255
2256   unless ($self->{IMG}) {
2257     $self->{ERRSTR}='empty input image';
2258     return undef;
2259   }
2260
2261   $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2262
2263   if ( !defined($img->{IMG}) ) {
2264     $self->{ERRSTR} = 'unable to scale image';
2265     return undef;
2266   }
2267
2268   return $img;
2269 }
2270
2271 # Scales only along the Y axis
2272
2273 sub scaleY {
2274   my $self = shift;
2275   my %opts = ( scalefactor => 0.5, @_ );
2276
2277   unless (defined wantarray) {
2278     my @caller = caller;
2279     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2280     return;
2281   }
2282
2283   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2284
2285   my $img = Imager->new();
2286
2287   my $scalefactor = $opts{scalefactor};
2288
2289   if ($opts{pixels}) {
2290     $scalefactor = $opts{pixels} / $self->getheight();
2291   }
2292
2293   unless ($self->{IMG}) {
2294     $self->{ERRSTR} = 'empty input image';
2295     return undef;
2296   }
2297   $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2298
2299   if ( !defined($img->{IMG}) ) {
2300     $self->{ERRSTR} = 'unable to scale image';
2301     return undef;
2302   }
2303
2304   return $img;
2305 }
2306
2307 # Transform returns a spatial transformation of the input image
2308 # this moves pixels to a new location in the returned image.
2309 # NOTE - should make a utility function to check transforms for
2310 # stack overruns
2311
2312 sub transform {
2313   my $self=shift;
2314   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2315   my %opts=@_;
2316   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2317
2318 #  print Dumper(\%opts);
2319 #  xopcopdes
2320
2321   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2322     if (!$I2P) {
2323       eval ("use Affix::Infix2Postfix;");
2324       print $@;
2325       if ( $@ ) {
2326         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2327         return undef;
2328       }
2329       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2330                                              {op=>'-',trans=>'Sub'},
2331                                              {op=>'*',trans=>'Mult'},
2332                                              {op=>'/',trans=>'Div'},
2333                                              {op=>'-','type'=>'unary',trans=>'u-'},
2334                                              {op=>'**'},
2335                                              {op=>'func','type'=>'unary'}],
2336                                      'grouping'=>[qw( \( \) )],
2337                                      'func'=>[qw( sin cos )],
2338                                      'vars'=>[qw( x y )]
2339                                     );
2340     }
2341
2342     @xt=$I2P->translate($opts{'xexpr'});
2343     @yt=$I2P->translate($opts{'yexpr'});
2344
2345     $numre=$I2P->{'numre'};
2346     @pt=(0,0);
2347
2348     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2349     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2350     @{$opts{'parm'}}=@pt;
2351   }
2352
2353 #  print Dumper(\%opts);
2354
2355   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2356     $self->{ERRSTR}='transform: no xopcodes given.';
2357     return undef;
2358   }
2359
2360   @op=@{$opts{'xopcodes'}};
2361   for $iop (@op) {
2362     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2363       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2364       return undef;
2365     }
2366     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2367   }
2368
2369
2370 # yopcopdes
2371
2372   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2373     $self->{ERRSTR}='transform: no yopcodes given.';
2374     return undef;
2375   }
2376
2377   @op=@{$opts{'yopcodes'}};
2378   for $iop (@op) {
2379     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2380       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2381       return undef;
2382     }
2383     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2384   }
2385
2386 #parameters
2387
2388   if ( !exists $opts{'parm'}) {
2389     $self->{ERRSTR}='transform: no parameter arg given.';
2390     return undef;
2391   }
2392
2393 #  print Dumper(\@ropx);
2394 #  print Dumper(\@ropy);
2395 #  print Dumper(\@ropy);
2396
2397   my $img = Imager->new();
2398   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2399   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2400   return $img;
2401 }
2402
2403
2404 sub transform2 {
2405   my ($opts, @imgs) = @_;
2406
2407   require "Imager/Expr.pm";
2408
2409   $opts->{variables} = [ qw(x y) ];
2410   my ($width, $height) = @{$opts}{qw(width height)};
2411   if (@imgs) {
2412     $width ||= $imgs[0]->getwidth();
2413     $height ||= $imgs[0]->getheight();
2414     my $img_num = 1;
2415     for my $img (@imgs) {
2416       $opts->{constants}{"w$img_num"} = $img->getwidth();
2417       $opts->{constants}{"h$img_num"} = $img->getheight();
2418       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2419       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2420       ++$img_num;
2421     }
2422   }
2423   if ($width) {
2424     $opts->{constants}{w} = $width;
2425     $opts->{constants}{cx} = $width/2;
2426   }
2427   else {
2428     $Imager::ERRSTR = "No width supplied";
2429     return;
2430   }
2431   if ($height) {
2432     $opts->{constants}{h} = $height;
2433     $opts->{constants}{cy} = $height/2;
2434   }
2435   else {
2436     $Imager::ERRSTR = "No height supplied";
2437     return;
2438   }
2439   my $code = Imager::Expr->new($opts);
2440   if (!$code) {
2441     $Imager::ERRSTR = Imager::Expr::error();
2442     return;
2443   }
2444   my $channels = $opts->{channels} || 3;
2445   unless ($channels >= 1 && $channels <= 4) {
2446     return Imager->_set_error("channels must be an integer between 1 and 4");
2447   }
2448
2449   my $img = Imager->new();
2450   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2451                              $channels, $code->code(),
2452                              $code->nregs(), $code->cregs(),
2453                              [ map { $_->{IMG} } @imgs ]);
2454   if (!defined $img->{IMG}) {
2455     $Imager::ERRSTR = Imager->_error_as_msg();
2456     return;
2457   }
2458
2459   return $img;
2460 }
2461
2462 sub rubthrough {
2463   my $self=shift;
2464   my %opts= @_;
2465
2466   unless ($self->{IMG}) {
2467     $self->{ERRSTR}='empty input image';
2468     return undef;
2469   }
2470   unless ($opts{src} && $opts{src}->{IMG}) {
2471     $self->{ERRSTR}='empty input image for src';
2472     return undef;
2473   }
2474
2475   %opts = (src_minx => 0,
2476            src_miny => 0,
2477            src_maxx => $opts{src}->getwidth(),
2478            src_maxy => $opts{src}->getheight(),
2479            %opts);
2480
2481   my $tx = $opts{tx};
2482   defined $tx or $tx = $opts{left};
2483   defined $tx or $tx = 0;
2484
2485   my $ty = $opts{ty};
2486   defined $ty or $ty = $opts{top};
2487   defined $ty or $ty = 0;
2488
2489   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
2490                     $opts{src_minx}, $opts{src_miny},
2491                     $opts{src_maxx}, $opts{src_maxy})) {
2492     $self->_set_error($self->_error_as_msg());
2493     return undef;
2494   }
2495
2496   return $self;
2497 }
2498
2499 sub compose {
2500   my $self = shift;
2501   my %opts =
2502     (
2503      opacity => 1.0,
2504      mask_left => 0,
2505      mask_top => 0,
2506      @_
2507     );
2508
2509   unless ($self->{IMG}) {
2510     $self->_set_error("compose: empty input image");
2511     return;
2512   }
2513
2514   unless ($opts{src}) {
2515     $self->_set_error("compose: src parameter missing");
2516     return;
2517   }
2518
2519   unless ($opts{src}{IMG}) {
2520     $self->_set_error("compose: src parameter empty image");
2521     return;
2522   }
2523   my $src = $opts{src};
2524
2525   my $left = $opts{left};
2526   defined $left or $left = $opts{tx};
2527   defined $left or $left = 0;
2528
2529   my $top = $opts{top};
2530   defined $top or $top = $opts{ty};
2531   defined $top or $top = 0;
2532
2533   my $src_left = $opts{src_left};
2534   defined $src_left or $src_left = $opts{src_minx};
2535   defined $src_left or $src_left = 0;
2536
2537   my $src_top = $opts{src_top};
2538   defined $src_top or $src_top = $opts{src_miny};
2539   defined $src_top or $src_top = 0;
2540
2541   my $width = $opts{width};
2542   if (!defined $width && defined $opts{src_maxx}) {
2543     $width = $opts{src_maxx} - $src_left;
2544   }
2545   defined $width or $width = $src->getwidth() - $src_left;
2546
2547   my $height = $opts{height};
2548   if (!defined $height && defined $opts{src_maxy}) {
2549     $height = $opts{src_maxy} - $src_top;
2550   }
2551   defined $height or $height = $src->getheight() - $src_top;
2552
2553   my $combine = $self->_combine($opts{combine}, 'normal');
2554
2555   if ($opts{mask}) {
2556     unless ($opts{mask}{IMG}) {
2557       $self->_set_error("compose: mask parameter empty image");
2558       return;
2559     }
2560
2561     my $mask_left = $opts{mask_left};
2562     defined $mask_left or $mask_left = $opts{mask_minx};
2563     defined $mask_left or $mask_left = 0;
2564
2565     my $mask_top = $opts{mask_top};
2566     defined $mask_top or $mask_top = $opts{mask_miny};
2567     defined $mask_top or $mask_top = 0;
2568
2569     unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
2570                    $left, $top, $src_left, $src_top,
2571                    $mask_left, $mask_top, $width, $height,
2572                            $combine, $opts{opacity})) {
2573       $self->_set_error(Imager->_error_as_msg);
2574       return;
2575     }
2576   }
2577   else {
2578     unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2579                       $width, $height, $combine, $opts{opacity})) {
2580       $self->_set_error(Imager->_error_as_msg);
2581       return;
2582     }
2583   }
2584
2585   return $self;
2586 }
2587
2588 sub flip {
2589   my $self  = shift;
2590   my %opts  = @_;
2591   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2592   my $dir;
2593   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2594   $dir = $xlate{$opts{'dir'}};
2595   return $self if i_flipxy($self->{IMG}, $dir);
2596   return ();
2597 }
2598
2599 sub rotate {
2600   my $self = shift;
2601   my %opts = @_;
2602
2603   unless (defined wantarray) {
2604     my @caller = caller;
2605     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2606     return;
2607   }
2608
2609   if (defined $opts{right}) {
2610     my $degrees = $opts{right};
2611     if ($degrees < 0) {
2612       $degrees += 360 * int(((-$degrees)+360)/360);
2613     }
2614     $degrees = $degrees % 360;
2615     if ($degrees == 0) {
2616       return $self->copy();
2617     }
2618     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2619       my $result = Imager->new();
2620       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2621         return $result;
2622       }
2623       else {
2624         $self->{ERRSTR} = $self->_error_as_msg();
2625         return undef;
2626       }
2627     }
2628     else {
2629       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2630       return undef;
2631     }
2632   }
2633   elsif (defined $opts{radians} || defined $opts{degrees}) {
2634     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2635
2636     my $back = $opts{back};
2637     my $result = Imager->new;
2638     if ($back) {
2639       $back = _color($back);
2640       unless ($back) {
2641         $self->_set_error(Imager->errstr);
2642         return undef;
2643       }
2644
2645       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2646     }
2647     else {
2648       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2649     }
2650     if ($result->{IMG}) {
2651       return $result;
2652     }
2653     else {
2654       $self->{ERRSTR} = $self->_error_as_msg();
2655       return undef;
2656     }
2657   }
2658   else {
2659     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2660     return undef;
2661   }
2662 }
2663
2664 sub matrix_transform {
2665   my $self = shift;
2666   my %opts = @_;
2667
2668   unless (defined wantarray) {
2669     my @caller = caller;
2670     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2671     return;
2672   }
2673
2674   if ($opts{matrix}) {
2675     my $xsize = $opts{xsize} || $self->getwidth;
2676     my $ysize = $opts{ysize} || $self->getheight;
2677
2678     my $result = Imager->new;
2679     if ($opts{back}) {
2680       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2681                                           $opts{matrix}, $opts{back})
2682         or return undef;
2683     }
2684     else {
2685       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2686                                           $opts{matrix})
2687         or return undef;
2688     }
2689
2690     return $result;
2691   }
2692   else {
2693     $self->{ERRSTR} = "matrix parameter required";
2694     return undef;
2695   }
2696 }
2697
2698 # blame Leolo :)
2699 *yatf = \&matrix_transform;
2700
2701 # These two are supported for legacy code only
2702
2703 sub i_color_new {
2704   return Imager::Color->new(@_);
2705 }
2706
2707 sub i_color_set {
2708   return Imager::Color::set(@_);
2709 }
2710
2711 # Draws a box between the specified corner points.
2712 sub box {
2713   my $self=shift;
2714   my $raw = $self->{IMG};
2715
2716   unless ($raw) {
2717     $self->{ERRSTR}='empty input image';
2718     return undef;
2719   }
2720
2721   my %opts = @_;
2722
2723   my ($xmin, $ymin, $xmax, $ymax);
2724   if (exists $opts{'box'}) {
2725     $xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2726     $xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2727     $ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2728     $ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2729   }
2730   else {
2731     defined($xmin = $opts{xmin}) or $xmin = 0;
2732     defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
2733     defined($ymin = $opts{ymin}) or $ymin = 0;
2734     defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
2735   }
2736
2737   if ($opts{filled}) {
2738     my $color = $opts{'color'};
2739
2740     if (defined $color) {
2741       unless (_is_color_object($color)) {
2742         $color = _color($color);
2743         unless ($color) {
2744           $self->{ERRSTR} = $Imager::ERRSTR;
2745           return;
2746         }
2747       }
2748     }
2749     else {
2750       $color = i_color_new(255,255,255,255);
2751     }
2752
2753     if ($color->isa("Imager::Color")) {
2754       i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
2755     }
2756     else {
2757       i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
2758     }
2759   }
2760   elsif ($opts{fill}) {
2761     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2762       # assume it's a hash ref
2763       require 'Imager/Fill.pm';
2764       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2765         $self->{ERRSTR} = $Imager::ERRSTR;
2766         return undef;
2767       }
2768     }
2769     i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
2770   }
2771   else {
2772     my $color = $opts{'color'};
2773     if (defined $color) {
2774       unless (_is_color_object($color)) {
2775         $color = _color($color);
2776         unless ($color) {
2777           $self->{ERRSTR} = $Imager::ERRSTR;
2778           return;
2779         }
2780       }
2781     }
2782     else {
2783       $color = i_color_new(255, 255, 255, 255);
2784     }
2785     unless ($color) {
2786       $self->{ERRSTR} = $Imager::ERRSTR;
2787       return;
2788     }
2789     i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
2790   }
2791
2792   return $self;
2793 }
2794
2795 sub arc {
2796   my $self=shift;
2797   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2798   my $dflcl= [ 255, 255, 255, 255];
2799   my $good = 1;
2800   my %opts=
2801     (
2802      color=>$dflcl,
2803      'r'=>_min($self->getwidth(),$self->getheight())/3,
2804      'x'=>$self->getwidth()/2,
2805      'y'=>$self->getheight()/2,
2806      'd1'=>0, 'd2'=>361,
2807      filled => 1,
2808      @_,
2809     );
2810   if ($opts{aa}) {
2811     if ($opts{fill}) {
2812       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2813         # assume it's a hash ref
2814         require 'Imager/Fill.pm';
2815         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2816           $self->{ERRSTR} = $Imager::ERRSTR;
2817           return;
2818         }
2819       }
2820       i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2821                      $opts{'d2'}, $opts{fill}{fill});
2822     }
2823     elsif ($opts{filled}) {
2824       my $color = _color($opts{'color'});
2825       unless ($color) {
2826         $self->{ERRSTR} = $Imager::ERRSTR;
2827         return;
2828       }
2829       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2830         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2831                     $color);
2832       }
2833       else {
2834         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2835                  $opts{'d1'}, $opts{'d2'}, $color);
2836       }
2837     }
2838     else {
2839       my $color = _color($opts{'color'});
2840       if ($opts{d2} - $opts{d1} >= 360) {
2841         $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2842       }
2843       else {
2844         $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2845       }
2846     }
2847   }
2848   else {
2849     if ($opts{fill}) {
2850       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2851         # assume it's a hash ref
2852         require 'Imager/Fill.pm';
2853         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2854           $self->{ERRSTR} = $Imager::ERRSTR;
2855           return;
2856         }
2857       }
2858       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2859                   $opts{'d2'}, $opts{fill}{fill});
2860     }
2861     else {
2862       my $color = _color($opts{'color'});
2863       unless ($color) {
2864         $self->{ERRSTR} = $Imager::ERRSTR;
2865         return;
2866       }
2867       if ($opts{filled}) {
2868         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2869               $opts{'d1'}, $opts{'d2'}, $color);
2870       }
2871       else {
2872         if ($opts{d1} == 0 && $opts{d2} == 361) {
2873           $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2874         }
2875         else {
2876           $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2877         }
2878       }
2879     }
2880   }
2881   unless ($good) {
2882     $self->_set_error($self->_error_as_msg);
2883     return;
2884   }
2885
2886   return $self;
2887 }
2888
2889 # Draws a line from one point to the other
2890 # the endpoint is set if the endp parameter is set which it is by default.
2891 # to turn of the endpoint being set use endp=>0 when calling line.
2892
2893 sub line {
2894   my $self=shift;
2895   my $dflcl=i_color_new(0,0,0,0);
2896   my %opts=(color=>$dflcl,
2897             endp => 1,
2898             @_);
2899   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2900
2901   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2902   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2903
2904   my $color = _color($opts{'color'});
2905   unless ($color) {
2906     $self->{ERRSTR} = $Imager::ERRSTR;
2907     return;
2908   }
2909
2910   $opts{antialias} = $opts{aa} if defined $opts{aa};
2911   if ($opts{antialias}) {
2912     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2913               $color, $opts{endp});
2914   } else {
2915     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2916            $color, $opts{endp});
2917   }
2918   return $self;
2919 }
2920
2921 # Draws a line between an ordered set of points - It more or less just transforms this
2922 # into a list of lines.
2923
2924 sub polyline {
2925   my $self=shift;
2926   my ($pt,$ls,@points);
2927   my $dflcl=i_color_new(0,0,0,0);
2928   my %opts=(color=>$dflcl,@_);
2929
2930   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2931
2932   if (exists($opts{points})) { @points=@{$opts{points}}; }
2933   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2934     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2935     }
2936
2937 #  print Dumper(\@points);
2938
2939   my $color = _color($opts{'color'});
2940   unless ($color) {
2941     $self->{ERRSTR} = $Imager::ERRSTR;
2942     return;
2943   }
2944   $opts{antialias} = $opts{aa} if defined $opts{aa};
2945   if ($opts{antialias}) {
2946     for $pt(@points) {
2947       if (defined($ls)) {
2948         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2949       }
2950       $ls=$pt;
2951     }
2952   } else {
2953     for $pt(@points) {
2954       if (defined($ls)) {
2955         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2956       }
2957       $ls=$pt;
2958     }
2959   }
2960   return $self;
2961 }
2962
2963 sub polygon {
2964   my $self = shift;
2965   my ($pt,$ls,@points);
2966   my $dflcl = i_color_new(0,0,0,0);
2967   my %opts = (color=>$dflcl, @_);
2968
2969   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2970
2971   if (exists($opts{points})) {
2972     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2973     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2974   }
2975
2976   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2977     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2978   }
2979
2980   if ($opts{'fill'}) {
2981     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2982       # assume it's a hash ref
2983       require 'Imager/Fill.pm';
2984       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2985         $self->{ERRSTR} = $Imager::ERRSTR;
2986         return undef;
2987       }
2988     }
2989     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2990                     $opts{'fill'}{'fill'});
2991   }
2992   else {
2993     my $color = _color($opts{'color'});
2994     unless ($color) {
2995       $self->{ERRSTR} = $Imager::ERRSTR;
2996       return;
2997     }
2998     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2999   }
3000
3001   return $self;
3002 }
3003
3004
3005 # this the multipoint bezier curve
3006 # this is here more for testing that actual usage since
3007 # this is not a good algorithm.  Usually the curve would be
3008 # broken into smaller segments and each done individually.
3009
3010 sub polybezier {
3011   my $self=shift;
3012   my ($pt,$ls,@points);
3013   my $dflcl=i_color_new(0,0,0,0);
3014   my %opts=(color=>$dflcl,@_);
3015
3016   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3017
3018   if (exists $opts{points}) {
3019     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
3020     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
3021   }
3022
3023   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
3024     $self->{ERRSTR}='Missing or invalid points.';
3025     return;
3026   }
3027
3028   my $color = _color($opts{'color'});
3029   unless ($color) {
3030     $self->{ERRSTR} = $Imager::ERRSTR;
3031     return;
3032   }
3033   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
3034   return $self;
3035 }
3036
3037 sub flood_fill {
3038   my $self = shift;
3039   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
3040   my $rc;
3041
3042   unless (exists $opts{'x'} && exists $opts{'y'}) {
3043     $self->{ERRSTR} = "missing seed x and y parameters";
3044     return undef;
3045   }
3046
3047   if ($opts{border}) {
3048     my $border = _color($opts{border});
3049     unless ($border) {
3050       $self->_set_error($Imager::ERRSTR);
3051       return;
3052     }
3053     if ($opts{fill}) {
3054       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3055         # assume it's a hash ref
3056         require Imager::Fill;
3057         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3058           $self->{ERRSTR} = $Imager::ERRSTR;
3059           return;
3060         }
3061       }
3062       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3063                                  $opts{fill}{fill}, $border);
3064     }
3065     else {
3066       my $color = _color($opts{'color'});
3067       unless ($color) {
3068         $self->{ERRSTR} = $Imager::ERRSTR;
3069         return;
3070       }
3071       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3072                                 $color, $border);
3073     }
3074     if ($rc) {
3075       return $self;
3076     }
3077     else {
3078       $self->{ERRSTR} = $self->_error_as_msg();
3079       return;
3080     }
3081   }
3082   else {
3083     if ($opts{fill}) {
3084       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3085         # assume it's a hash ref
3086         require 'Imager/Fill.pm';
3087         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3088           $self->{ERRSTR} = $Imager::ERRSTR;
3089           return;
3090         }
3091       }
3092       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3093     }
3094     else {
3095       my $color = _color($opts{'color'});
3096       unless ($color) {
3097         $self->{ERRSTR} = $Imager::ERRSTR;
3098         return;
3099       }
3100       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3101     }
3102     if ($rc) {
3103       return $self;
3104     }
3105     else {
3106       $self->{ERRSTR} = $self->_error_as_msg();
3107       return;
3108     }
3109   }
3110 }
3111
3112 sub setpixel {
3113   my ($self, %opts) = @_;
3114
3115   $self->_valid_image("setpixel")
3116     or return;
3117
3118   my $color = $opts{color};
3119   unless (defined $color) {
3120     $color = $self->{fg};
3121     defined $color or $color = NC(255, 255, 255);
3122   }
3123
3124   unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3125     unless ($color = _color($color, 'setpixel')) {
3126       $self->_set_error("setpixel: " . Imager->errstr);
3127       return;
3128     }
3129   }
3130
3131   unless (exists $opts{'x'} && exists $opts{'y'}) {
3132     $self->_set_error('setpixel: missing x or y parameter');
3133     return;
3134   }
3135
3136   my $x = $opts{'x'};
3137   my $y = $opts{'y'};
3138   if (ref $x || ref $y) {
3139     $x = ref $x ? $x : [ $x ];
3140     $y = ref $y ? $y : [ $y ];
3141     unless (@$x) {
3142       $self->_set_error("setpixel: x is a reference to an empty array");
3143       return;
3144     }
3145     unless (@$y) {
3146       $self->_set_error("setpixel: y is a reference to an empty array");
3147       return;
3148     }
3149
3150     # make both the same length, replicating the last element
3151     if (@$x < @$y) {
3152       $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3153     }
3154     elsif (@$y < @$x) {
3155       $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3156     }
3157
3158     my $set = 0;
3159     if ($color->isa('Imager::Color')) {
3160       for my $i (0..$#$x) {
3161         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3162           or ++$set;
3163       }
3164     }
3165     else {
3166       for my $i (0..$#$x) {
3167         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3168           or ++$set;
3169       }
3170     }
3171
3172     return $set;
3173   }
3174   else {
3175     if ($color->isa('Imager::Color')) {
3176       i_ppix($self->{IMG}, $x, $y, $color)
3177         and return;
3178     }
3179     else {
3180       i_ppixf($self->{IMG}, $x, $y, $color)
3181         and return;
3182     }
3183   }
3184
3185   return $self;
3186 }
3187
3188 sub getpixel {
3189   my $self = shift;
3190
3191   my %opts = ( "type"=>'8bit', @_);
3192
3193   $self->_valid_image("getpixel")
3194     or return;
3195
3196   unless (exists $opts{'x'} && exists $opts{'y'}) {
3197     $self->_set_error('getpixel: missing x or y parameter');
3198     return;
3199   }
3200
3201   my $x = $opts{'x'};
3202   my $y = $opts{'y'};
3203   my $type = $opts{'type'};
3204   if (ref $x || ref $y) {
3205     $x = ref $x ? $x : [ $x ];
3206     $y = ref $y ? $y : [ $y ];
3207     unless (@$x) {
3208       $self->_set_error("getpixel: x is a reference to an empty array");
3209       return;
3210     }
3211     unless (@$y) {
3212       $self->_set_error("getpixel: y is a reference to an empty array");
3213       return;
3214     }
3215
3216     # make both the same length, replicating the last element
3217     if (@$x < @$y) {
3218       $x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
3219     }
3220     elsif (@$y < @$x) {
3221       $y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
3222     }
3223
3224     my @result;
3225     if ($type eq '8bit') {
3226       for my $i (0..$#$x) {
3227         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3228       }
3229     }
3230     elsif ($type eq 'float' || $type eq 'double') {
3231       for my $i (0..$#$x) {
3232         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3233       }
3234     }
3235     else {
3236       $self->_set_error("getpixel: type must be '8bit' or 'float'");
3237       return;
3238     }
3239     return wantarray ? @result : \@result;
3240   }
3241   else {
3242     if ($type eq '8bit') {
3243       return i_get_pixel($self->{IMG}, $x, $y);
3244     }
3245     elsif ($type eq 'float' || $type eq 'double') {
3246       return i_gpixf($self->{IMG}, $x, $y);
3247     }
3248     else {
3249       $self->_set_error("getpixel: type must be '8bit' or 'float'");
3250       return;
3251     }
3252   }
3253 }
3254
3255 sub getscanline {
3256   my $self = shift;
3257   my %opts = ( type => '8bit', x=>0, @_);
3258
3259   $self->_valid_image or return;
3260
3261   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3262
3263   unless (defined $opts{'y'}) {
3264     $self->_set_error("missing y parameter");
3265     return;
3266   }
3267
3268   if ($opts{type} eq '8bit') {
3269     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3270                   $opts{'y'});
3271   }
3272   elsif ($opts{type} eq 'float') {
3273     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3274                   $opts{'y'});
3275   }
3276   elsif ($opts{type} eq 'index') {
3277     unless (i_img_type($self->{IMG})) {
3278       $self->_set_error("type => index only valid on paletted images");
3279       return;
3280     }
3281     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3282                   $opts{'y'});
3283   }
3284   else {
3285     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3286     return;
3287   }
3288 }
3289
3290 sub setscanline {
3291   my $self = shift;
3292   my %opts = ( x=>0, @_);
3293
3294   $self->_valid_image or return;
3295
3296   unless (defined $opts{'y'}) {
3297     $self->_set_error("missing y parameter");
3298     return;
3299   }
3300
3301   if (!$opts{type}) {
3302     if (ref $opts{pixels} && @{$opts{pixels}}) {
3303       # try to guess the type
3304       if ($opts{pixels}[0]->isa('Imager::Color')) {
3305         $opts{type} = '8bit';
3306       }
3307       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3308         $opts{type} = 'float';
3309       }
3310       else {
3311         $self->_set_error("missing type parameter and could not guess from pixels");
3312         return;
3313       }
3314     }
3315     else {
3316       # default
3317       $opts{type} = '8bit';
3318     }
3319   }
3320
3321   if ($opts{type} eq '8bit') {
3322     if (ref $opts{pixels}) {
3323       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3324     }
3325     else {
3326       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3327     }
3328   }
3329   elsif ($opts{type} eq 'float') {
3330     if (ref $opts{pixels}) {
3331       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3332     }
3333     else {
3334       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3335     }
3336   }
3337   elsif ($opts{type} eq 'index') {
3338     if (ref $opts{pixels}) {
3339       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3340     }
3341     else {
3342       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3343     }
3344   }
3345   else {
3346     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3347     return;
3348   }
3349 }
3350
3351 sub getsamples {
3352   my $self = shift;
3353   my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3354
3355   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3356
3357   unless (defined $opts{'y'}) {
3358     $self->_set_error("missing y parameter");
3359     return;
3360   }
3361
3362   if ($opts{target}) {
3363     my $target = $opts{target};
3364     my $offset = $opts{offset};
3365     if ($opts{type} eq '8bit') {
3366       my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3367                             $opts{y}, $opts{channels})
3368         or return;
3369       @{$target}[$offset .. $offset + @samples - 1] = @samples;
3370       return scalar(@samples);
3371     }
3372     elsif ($opts{type} eq 'float') {
3373       my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3374                              $opts{y}, $opts{channels});
3375       @{$target}[$offset .. $offset + @samples - 1] = @samples;
3376       return scalar(@samples);
3377     }
3378     elsif ($opts{type} =~ /^(\d+)bit$/) {
3379       my $bits = $1;
3380
3381       my @data;
3382       my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3383                                $opts{y}, $bits, $target,
3384                                $offset, $opts{channels});
3385       unless (defined $count) {
3386         $self->_set_error(Imager->_error_as_msg);
3387         return;
3388       }
3389
3390       return $count;
3391     }
3392     else {
3393       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3394       return;
3395     }
3396   }
3397   else {
3398     if ($opts{type} eq '8bit') {
3399       return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3400                      $opts{y}, $opts{channels});
3401     }
3402     elsif ($opts{type} eq 'float') {
3403       return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3404                       $opts{y}, $opts{channels});
3405     }
3406     elsif ($opts{type} =~ /^(\d+)bit$/) {
3407       my $bits = $1;
3408
3409       my @data;
3410       i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3411                    $opts{y}, $bits, \@data, 0, $opts{channels})
3412         or return;
3413       return @data;
3414     }
3415     else {
3416       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3417       return;
3418     }
3419   }
3420 }
3421
3422 sub setsamples {
3423   my $self = shift;
3424   my %opts = ( x => 0, offset => 0, @_ );
3425
3426   unless ($self->{IMG}) {
3427     $self->_set_error('setsamples: empty input image');
3428     return;
3429   }
3430
3431   my $data = $opts{data};
3432   unless(defined $data) {
3433     $self->_set_error('setsamples: data parameter missing');
3434     return;
3435   }
3436
3437   my $type = $opts{type};
3438   defined $type or $type = '8bit';
3439
3440   my $width = defined $opts{width} ? $opts{width}
3441     : $self->getwidth() - $opts{x};
3442
3443   my $count;
3444   if ($type eq '8bit') {
3445     $count = i_psamp($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3446                      $data, $opts{offset}, $width);
3447   }
3448   elsif ($type eq 'float') {
3449     $count = i_psampf($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
3450                       $data, $opts{offset}, $width);
3451   }
3452   elsif ($type =~ /^([0-9]+)bit$/) {
3453     my $bits = $1;
3454
3455     unless (ref $data) {
3456       $self->_set_error("setsamples: data must be an array ref for type not 8bit or float");
3457       return;
3458     }
3459
3460     $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3461                           $opts{channels}, $data, $opts{offset},
3462                           $width);
3463   }
3464   else {
3465     $self->_set_error('setsamples: type parameter invalid');
3466     return;
3467   }
3468
3469   unless (defined $count) {
3470     $self->_set_error(Imager->_error_as_msg);
3471     return;
3472   }
3473
3474   return $count;
3475 }
3476
3477 # make an identity matrix of the given size
3478 sub _identity {
3479   my ($size) = @_;
3480
3481   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3482   for my $c (0 .. ($size-1)) {
3483     $matrix->[$c][$c] = 1;
3484   }
3485   return $matrix;
3486 }
3487
3488 # general function to convert an image
3489 sub convert {
3490   my ($self, %opts) = @_;
3491   my $matrix;
3492
3493   unless (defined wantarray) {
3494     my @caller = caller;
3495     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3496     return;
3497   }
3498
3499   # the user can either specify a matrix or preset
3500   # the matrix overrides the preset
3501   if (!exists($opts{matrix})) {
3502     unless (exists($opts{preset})) {
3503       $self->{ERRSTR} = "convert() needs a matrix or preset";
3504       return;
3505     }
3506     else {
3507       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3508         # convert to greyscale, keeping the alpha channel if any
3509         if ($self->getchannels == 3) {
3510           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3511         }
3512         elsif ($self->getchannels == 4) {
3513           # preserve the alpha channel
3514           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3515                       [ 0,     0,     0,     1 ] ];
3516         }
3517         else {
3518           # an identity
3519           $matrix = _identity($self->getchannels);
3520         }
3521       }
3522       elsif ($opts{preset} eq 'noalpha') {
3523         # strip the alpha channel
3524         if ($self->getchannels == 2 or $self->getchannels == 4) {
3525           $matrix = _identity($self->getchannels);
3526           pop(@$matrix); # lose the alpha entry
3527         }
3528         else {
3529           $matrix = _identity($self->getchannels);
3530         }
3531       }
3532       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3533         # extract channel 0
3534         $matrix = [ [ 1 ] ];
3535       }
3536       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3537         $matrix = [ [ 0, 1 ] ];
3538       }
3539       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3540         $matrix = [ [ 0, 0, 1 ] ];
3541       }
3542       elsif ($opts{preset} eq 'alpha') {
3543         if ($self->getchannels == 2 or $self->getchannels == 4) {
3544           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3545         }
3546         else {
3547           # the alpha is just 1 <shrug>
3548           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3549         }
3550       }
3551       elsif ($opts{preset} eq 'rgb') {
3552         if ($self->getchannels == 1) {
3553           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3554         }
3555         elsif ($self->getchannels == 2) {
3556           # preserve the alpha channel
3557           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3558         }
3559         else {
3560           $matrix = _identity($self->getchannels);
3561         }
3562       }
3563       elsif ($opts{preset} eq 'addalpha') {
3564         if ($self->getchannels == 1) {
3565           $matrix = _identity(2);
3566         }
3567         elsif ($self->getchannels == 3) {
3568           $matrix = _identity(4);
3569         }
3570         else {
3571           $matrix = _identity($self->getchannels);
3572         }
3573       }
3574       else {
3575         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3576         return undef;
3577       }
3578     }
3579   }
3580   else {
3581     $matrix = $opts{matrix};
3582   }
3583
3584   my $new = Imager->new;
3585   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3586   unless ($new->{IMG}) {
3587     # most likely a bad matrix
3588     $self->{ERRSTR} = _error_as_msg();
3589     return undef;
3590   }
3591   return $new;
3592 }
3593
3594 # combine channels from multiple input images, a class method
3595 sub combine {
3596   my ($class, %opts) = @_;
3597
3598   my $src = delete $opts{src};
3599   unless ($src) {
3600     $class->_set_error("src parameter missing");
3601     return;
3602   }
3603   my @imgs;
3604   my $index = 0;
3605   for my $img (@$src) {
3606     unless (eval { $img->isa("Imager") }) {
3607       $class->_set_error("src must contain image objects");
3608       return;
3609     }
3610     unless ($img->{IMG}) {
3611       $class->_set_error("empty input image");
3612       return;
3613     }
3614     push @imgs, $img->{IMG};
3615   }
3616   my $result;
3617   if (my $channels = delete $opts{channels}) {
3618     $result = i_combine(\@imgs, $channels);
3619   }
3620   else {
3621     $result = i_combine(\@imgs);
3622   }
3623   unless ($result) {
3624     $class->_set_error($class->_error_as_msg);
3625     return;
3626   }
3627
3628   my $img = $class->new;
3629   $img->{IMG} = $result;
3630
3631   return $img;
3632 }
3633
3634
3635 # general function to map an image through lookup tables
3636
3637 sub map {
3638   my ($self, %opts) = @_;
3639   my @chlist = qw( red green blue alpha );
3640
3641   if (!exists($opts{'maps'})) {
3642     # make maps from channel maps
3643     my $chnum;
3644     for $chnum (0..$#chlist) {
3645       if (exists $opts{$chlist[$chnum]}) {
3646         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3647       } elsif (exists $opts{'all'}) {
3648         $opts{'maps'}[$chnum] = $opts{'all'};
3649       }
3650     }
3651   }
3652   if ($opts{'maps'} and $self->{IMG}) {
3653     i_map($self->{IMG}, $opts{'maps'} );
3654   }
3655   return $self;
3656 }
3657
3658 sub difference {
3659   my ($self, %opts) = @_;
3660
3661   defined $opts{mindist} or $opts{mindist} = 0;
3662
3663   defined $opts{other}
3664     or return $self->_set_error("No 'other' parameter supplied");
3665   defined $opts{other}{IMG}
3666     or return $self->_set_error("No image data in 'other' image");
3667
3668   $self->{IMG}
3669     or return $self->_set_error("No image data");
3670
3671   my $result = Imager->new;
3672   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3673                                 $opts{mindist})
3674     or return $self->_set_error($self->_error_as_msg());
3675
3676   return $result;
3677 }
3678
3679 # destructive border - image is shrunk by one pixel all around
3680
3681 sub border {
3682   my ($self,%opts)=@_;
3683   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3684   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3685 }
3686
3687
3688 # Get the width of an image
3689
3690 sub getwidth {
3691   my $self = shift;
3692
3693   if (my $raw = $self->{IMG}) {
3694     return i_img_get_width($raw);
3695   }
3696   else {
3697     $self->{ERRSTR} = 'image is empty'; return undef;
3698   }
3699 }
3700
3701 # Get the height of an image
3702
3703 sub getheight {
3704   my $self = shift;
3705
3706   if (my $raw = $self->{IMG}) {
3707     return i_img_get_height($raw);
3708   }
3709   else {
3710     $self->{ERRSTR} = 'image is empty'; return undef;
3711   }
3712 }
3713
3714 # Get number of channels in an image
3715
3716 sub getchannels {
3717   my $self = shift;
3718   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3719   return i_img_getchannels($self->{IMG});
3720 }
3721
3722 # Get channel mask
3723
3724 sub getmask {
3725   my $self = shift;
3726   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3727   return i_img_getmask($self->{IMG});
3728 }
3729
3730 # Set channel mask
3731
3732 sub setmask {
3733   my $self = shift;
3734   my %opts = @_;
3735   if (!defined($self->{IMG})) {
3736     $self->{ERRSTR} = 'image is empty';
3737     return undef;
3738   }
3739   unless (defined $opts{mask}) {
3740     $self->_set_error("mask parameter required");
3741     return;
3742   }
3743   i_img_setmask( $self->{IMG} , $opts{mask} );
3744
3745   1;
3746 }
3747
3748 # Get number of colors in an image
3749
3750 sub getcolorcount {
3751   my $self=shift;
3752   my %opts=('maxcolors'=>2**30,@_);
3753   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3754   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3755   return ($rc==-1? undef : $rc);
3756 }
3757
3758 # Returns a reference to a hash. The keys are colour named (packed) and the
3759 # values are the number of pixels in this colour.
3760 sub getcolorusagehash {
3761   my $self = shift;
3762
3763   my %opts = ( maxcolors => 2**30, @_ );
3764   my $max_colors = $opts{maxcolors};
3765   unless (defined $max_colors && $max_colors > 0) {
3766     $self->_set_error('maxcolors must be a positive integer');
3767     return;
3768   }
3769
3770   unless (defined $self->{IMG}) {
3771     $self->_set_error('empty input image');
3772     return;
3773   }
3774
3775   my $channels= $self->getchannels;
3776   # We don't want to look at the alpha channel, because some gifs using it
3777   # doesn't define it for every colour (but only for some)
3778   $channels -= 1 if $channels == 2 or $channels == 4;
3779   my %color_use;
3780   my $height = $self->getheight;
3781   for my $y (0 .. $height - 1) {
3782     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3783     while (length $colors) {
3784       $color_use{ substr($colors, 0, $channels, '') }++;
3785     }
3786     keys %color_use > $max_colors
3787       and return;
3788   }
3789   return \%color_use;
3790 }
3791
3792 # This will return a ordered array of the colour usage. Kind of the sorted
3793 # version of the values of the hash returned by getcolorusagehash.
3794 # You might want to add safety checks and change the names, etc...
3795 sub getcolorusage {
3796   my $self = shift;
3797
3798   my %opts = ( maxcolors => 2**30, @_ );
3799   my $max_colors = $opts{maxcolors};
3800   unless (defined $max_colors && $max_colors > 0) {
3801     $self->_set_error('maxcolors must be a positive integer');
3802     return;
3803   }
3804
3805   unless (defined $self->{IMG}) {
3806     $self->_set_error('empty input image');
3807     return undef;
3808   }
3809
3810   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3811 }
3812
3813 # draw string to an image
3814
3815 sub string {
3816   my $self = shift;
3817   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3818
3819   my %input=('x'=>0, 'y'=>0, @_);
3820   defined($input{string}) or $input{string} = $input{text};
3821
3822   unless(defined $input{string}) {
3823     $self->{ERRSTR}="missing required parameter 'string'";
3824     return;
3825   }
3826
3827   unless($input{font}) {
3828     $self->{ERRSTR}="missing required parameter 'font'";
3829     return;
3830   }
3831
3832   unless ($input{font}->draw(image=>$self, %input)) {
3833     return;
3834   }
3835
3836   return $self;
3837 }
3838
3839 sub align_string {
3840   my $self = shift;
3841
3842   my $img;
3843   if (ref $self) {
3844     unless ($self->{IMG}) {
3845       $self->{ERRSTR}='empty input image';
3846       return;
3847     }
3848     $img = $self;
3849   }
3850   else {
3851     $img = undef;
3852   }
3853
3854   my %input=('x'=>0, 'y'=>0, @_);
3855   defined $input{string}
3856     or $input{string} = $input{text};
3857
3858   unless(exists $input{string}) {
3859     $self->_set_error("missing required parameter 'string'");
3860     return;
3861   }
3862
3863   unless($input{font}) {
3864     $self->_set_error("missing required parameter 'font'");
3865     return;
3866   }
3867
3868   my @result;
3869   unless (@result = $input{font}->align(image=>$img, %input)) {
3870     return;
3871   }
3872
3873   return wantarray ? @result : $result[0];
3874 }
3875
3876 my @file_limit_names = qw/width height bytes/;
3877
3878 sub set_file_limits {
3879   shift;
3880
3881   my %opts = @_;
3882   my %values;
3883
3884   if ($opts{reset}) {
3885     @values{@file_limit_names} = (0) x @file_limit_names;
3886   }
3887   else {
3888     @values{@file_limit_names} = i_get_image_file_limits();
3889   }
3890
3891   for my $key (keys %values) {
3892     defined $opts{$key} and $values{$key} = $opts{$key};
3893   }
3894
3895   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3896 }
3897
3898 sub get_file_limits {
3899   i_get_image_file_limits();
3900 }
3901
3902 # Shortcuts that can be exported
3903
3904 sub newcolor { Imager::Color->new(@_); }
3905 sub newfont  { Imager::Font->new(@_); }
3906 sub NCF {
3907   require Imager::Color::Float;
3908   return Imager::Color::Float->new(@_);
3909 }
3910
3911 *NC=*newcolour=*newcolor;
3912 *NF=*newfont;
3913
3914 *open=\&read;
3915 *circle=\&arc;
3916
3917
3918 #### Utility routines
3919
3920 sub errstr {
3921   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3922 }
3923
3924 sub _set_error {
3925   my ($self, $msg) = @_;
3926
3927   if (ref $self) {
3928     $self->{ERRSTR} = $msg;
3929   }
3930   else {
3931     $ERRSTR = $msg;
3932   }
3933   return;
3934 }
3935
3936 # Default guess for the type of an image from extension
3937
3938 my @simple_types = qw(png tga gif raw ico cur xpm mng jng ilbm pcx psd eps);
3939
3940 my %ext_types =
3941   (
3942    ( map { $_ => $_ } @simple_types ),
3943    tiff => "tiff",
3944    tif => "tiff",
3945    pbm => "pnm",
3946    pgm => "pnm",
3947    ppm => "pnm",
3948    pnm => "pnm", # technically wrong, but historically it works in Imager
3949    jpeg => "jpeg",
3950    jpg => "jpeg",
3951    bmp => "bmp",
3952    dib => "bmp",
3953    rgb => "sgi",
3954    bw => "sgi",
3955    sgi => "sgi",
3956    fit => "fits",
3957    fits => "fits",
3958    rle => "utah",
3959   );
3960
3961 sub def_guess_type {
3962   my $name=lc(shift);
3963
3964   my ($ext) = $name =~ /\.([^.]+)$/
3965     or return;
3966
3967   my $type = $ext_types{$ext}
3968     or return;
3969
3970   return $type;
3971 }
3972
3973 sub combines {
3974   return @combine_types;
3975 }
3976
3977 # get the minimum of a list
3978
3979 sub _min {
3980   my $mx=shift;
3981   for(@_) { if ($_<$mx) { $mx=$_; }}
3982   return $mx;
3983 }
3984
3985 # get the maximum of a list
3986
3987 sub _max {
3988   my $mx=shift;
3989   for(@_) { if ($_>$mx) { $mx=$_; }}
3990   return $mx;
3991 }
3992
3993 # string stuff for iptc headers
3994
3995 sub _clean {
3996   my($str)=$_[0];
3997   $str = substr($str,3);
3998   $str =~ s/[\n\r]//g;
3999   $str =~ s/\s+/ /g;
4000   $str =~ s/^\s//;
4001   $str =~ s/\s$//;
4002   return $str;
4003 }
4004
4005 # A little hack to parse iptc headers.
4006
4007 sub parseiptc {
4008   my $self=shift;
4009   my(@sar,$item,@ar);
4010   my($caption,$photogr,$headln,$credit);
4011
4012   my $str=$self->{IPTCRAW};
4013
4014   defined $str
4015     or return;
4016
4017   @ar=split(/8BIM/,$str);
4018
4019   my $i=0;
4020   foreach (@ar) {
4021     if (/^\004\004/) {
4022       @sar=split(/\034\002/);
4023       foreach $item (@sar) {
4024         if ($item =~ m/^x/) {
4025           $caption = _clean($item);
4026           $i++;
4027         }
4028         if ($item =~ m/^P/) {
4029           $photogr = _clean($item);
4030           $i++;
4031         }
4032         if ($item =~ m/^i/) {
4033           $headln = _clean($item);
4034           $i++;
4035         }
4036         if ($item =~ m/^n/) {
4037           $credit = _clean($item);
4038           $i++;
4039         }
4040       }
4041     }
4042   }
4043   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
4044 }
4045
4046 sub Inline {
4047   my ($lang) = @_;
4048
4049   $lang eq 'C'
4050     or die "Only C language supported";
4051
4052   require Imager::ExtUtils;
4053   return Imager::ExtUtils->inline_config;
4054 }
4055
4056 # threads shouldn't try to close raw Imager objects
4057 sub Imager::ImgRaw::CLONE_SKIP { 1 }
4058
4059 sub preload {
4060   # this serves two purposes:
4061   # - a class method to load the file support modules included with Imager
4062   #   (or were included, once the library dependent modules are split out)
4063   # - something for Module::ScanDeps to analyze
4064   # https://rt.cpan.org/Ticket/Display.html?id=6566
4065   local $@;
4066   eval { require Imager::File::GIF };
4067   eval { require Imager::File::JPEG };
4068   eval { require Imager::File::PNG };
4069   eval { require Imager::File::SGI };
4070   eval { require Imager::File::TIFF };
4071   eval { require Imager::File::ICO };
4072   eval { require Imager::Font::W32 };
4073   eval { require Imager::Font::FT2 };
4074   eval { require Imager::Font::T1 };
4075 }
4076
4077 # backward compatibility for %formats
4078 package Imager::FORMATS;
4079 use strict;
4080 use constant IX_FORMATS => 0;
4081 use constant IX_LIST => 1;
4082 use constant IX_INDEX => 2;
4083 use constant IX_CLASSES => 3;
4084
4085 sub TIEHASH {
4086   my ($class, $formats, $classes) = @_;
4087
4088   return bless [ $formats, [ ], 0, $classes ], $class;
4089 }
4090
4091 sub _check {
4092   my ($self, $key) = @_;
4093
4094   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4095   my $value;
4096   my $error;
4097   my $loaded = Imager::_load_file($file, \$error);
4098   if ($loaded) {
4099     $value = 1;
4100   }
4101   else {
4102     if ($error =~ /^Can't locate /) {
4103       $error = "Can't locate $file";
4104     }
4105     $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
4106     $value = undef;
4107   }
4108   $self->[IX_FORMATS]{$key} = $value;
4109
4110   return $value;
4111 }
4112
4113 sub FETCH {
4114   my ($self, $key) = @_;
4115
4116   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4117
4118   $self->[IX_CLASSES]{$key} or return undef;
4119
4120   return $self->_check($key);
4121 }
4122
4123 sub STORE {
4124   die "%Imager::formats is not user monifiable";
4125 }
4126
4127 sub DELETE {
4128   die "%Imager::formats is not user monifiable";
4129 }
4130
4131 sub CLEAR {
4132   die "%Imager::formats is not user monifiable";
4133 }
4134
4135 sub EXISTS {
4136   my ($self, $key) = @_;
4137
4138   if (exists $self->[IX_FORMATS]{$key}) {
4139     my $value = $self->[IX_FORMATS]{$key}
4140       or return;
4141     return 1;
4142   }
4143
4144   $self->_check($key) or return 1==0;
4145
4146   return 1==1;
4147 }
4148
4149 sub FIRSTKEY {
4150   my ($self) = @_;
4151
4152   unless (@{$self->[IX_LIST]}) {
4153     # full populate it
4154     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4155       keys %{$self->[IX_FORMATS]};
4156
4157     for my $key (keys %{$self->[IX_CLASSES]}) {
4158       $self->[IX_FORMATS]{$key} and next;
4159       $self->_check($key)
4160         and push @{$self->[IX_LIST]}, $key;
4161     }
4162   }
4163
4164   @{$self->[IX_LIST]} or return;
4165   $self->[IX_INDEX] = 1;
4166   return $self->[IX_LIST][0];
4167 }
4168
4169 sub NEXTKEY {
4170   my ($self) = @_;
4171
4172   $self->[IX_INDEX] < @{$self->[IX_LIST]}
4173     or return;
4174
4175   return $self->[IX_LIST][$self->[IX_INDEX]++];
4176 }
4177
4178 sub SCALAR {
4179   my ($self) = @_;
4180
4181   return scalar @{$self->[IX_LIST]};
4182 }
4183
4184 1;
4185 __END__
4186 # Below is the stub of documentation for your module. You better edit it!
4187
4188 =head1 NAME
4189
4190 Imager - Perl extension for Generating 24 bit Images
4191
4192 =head1 SYNOPSIS
4193
4194   # Thumbnail example
4195
4196   #!/usr/bin/perl -w
4197   use strict;
4198   use Imager;
4199
4200   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
4201   my $file = shift;
4202
4203   my $format;
4204
4205   # see Imager::Files for information on the read() method
4206   my $img = Imager->new(file=>$file)
4207     or die Imager->errstr();
4208
4209   $file =~ s/\.[^.]*$//;
4210
4211   # Create smaller version
4212   # documented in Imager::Transformations
4213   my $thumb = $img->scale(scalefactor=>.3);
4214
4215   # Autostretch individual channels
4216   $thumb->filter(type=>'autolevels');
4217
4218   # try to save in one of these formats
4219   SAVE:
4220
4221   for $format ( qw( png gif jpeg tiff ppm ) ) {
4222     # Check if given format is supported
4223     if ($Imager::formats{$format}) {
4224       $file.="_low.$format";
4225       print "Storing image as: $file\n";
4226       # documented in Imager::Files
4227       $thumb->write(file=>$file) or
4228         die $thumb->errstr;
4229       last SAVE;
4230     }
4231   }
4232
4233 =head1 DESCRIPTION
4234
4235 Imager is a module for creating and altering images.  It can read and
4236 write various image formats, draw primitive shapes like lines,and
4237 polygons, blend multiple images together in various ways, scale, crop,
4238 render text and more.
4239
4240 =head2 Overview of documentation
4241
4242 =over
4243
4244 =item *
4245
4246 Imager - This document - Synopsis, Example, Table of Contents and
4247 Overview.
4248
4249 =item *
4250
4251 L<Imager::Tutorial> - a brief introduction to Imager.
4252
4253 =item *
4254
4255 L<Imager::Cookbook> - how to do various things with Imager.
4256
4257 =item *
4258
4259 L<Imager::ImageTypes> - Basics of constructing image objects with
4260 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4261 8/16/double bits/channel, color maps, channel masks, image tags, color
4262 quantization.  Also discusses basic image information methods.
4263
4264 =item *
4265
4266 L<Imager::Files> - IO interaction, reading/writing images, format
4267 specific tags.
4268
4269 =item *
4270
4271 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4272 flood fill.
4273
4274 =item *
4275
4276 L<Imager::Color> - Color specification.
4277
4278 =item *
4279
4280 L<Imager::Fill> - Fill pattern specification.
4281
4282 =item *
4283
4284 L<Imager::Font> - General font rendering, bounding boxes and font
4285 metrics.
4286
4287 =item *
4288
4289 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4290 blending, pasting, convert and map.
4291
4292 =item *
4293
4294 L<Imager::Engines> - Programmable transformations through
4295 C<transform()>, C<transform2()> and C<matrix_transform()>.
4296
4297 =item *
4298
4299 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4300 filter plug-ins.
4301
4302 =item *
4303
4304 L<Imager::Expr> - Expressions for evaluation engine used by
4305 transform2().
4306
4307 =item *
4308
4309 L<Imager::Matrix2d> - Helper class for affine transformations.
4310
4311 =item *
4312
4313 L<Imager::Fountain> - Helper for making gradient profiles.
4314
4315 =item *
4316
4317 L<Imager::API> - using Imager's C API
4318
4319 =item *
4320
4321 L<Imager::APIRef> - API function reference
4322
4323 =item *
4324
4325 L<Imager::Inline> - using Imager's C API from Inline::C
4326
4327 =item *
4328
4329 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4330
4331 =back
4332
4333 =head2 Basic Overview
4334
4335 An Image object is created with C<$img = Imager-E<gt>new()>.
4336 Examples:
4337
4338   $img=Imager->new();                         # create empty image
4339   $img->read(file=>'lena.png',type=>'png') or # read image from file
4340      die $img->errstr();                      # give an explanation
4341                                               # if something failed
4342
4343 or if you want to create an empty image:
4344
4345   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4346
4347 This example creates a completely black image of width 400 and height
4348 300 and 4 channels.
4349
4350 =head1 ERROR HANDLING
4351
4352 In general a method will return false when it fails, if it does use
4353 the C<errstr()> method to find out why:
4354
4355 =over
4356
4357 =item errstr()
4358
4359 Returns the last error message in that context.
4360
4361 If the last error you received was from calling an object method, such
4362 as read, call errstr() as an object method to find out why:
4363
4364   my $image = Imager->new;
4365   $image->read(file => 'somefile.gif')
4366      or die $image->errstr;
4367
4368 If it was a class method then call errstr() as a class method:
4369
4370   my @imgs = Imager->read_multi(file => 'somefile.gif')
4371     or die Imager->errstr;
4372
4373 Note that in some cases object methods are implemented in terms of
4374 class methods so a failing object method may set both.
4375
4376 =back
4377
4378 The C<Imager-E<gt>new> method is described in detail in
4379 L<Imager::ImageTypes>.
4380
4381 =head1 METHOD INDEX
4382
4383 Where to find information on methods for Imager class objects.
4384
4385 addcolors() - L<Imager::ImageTypes/addcolors()> - add colors to a
4386 paletted image
4387
4388 addtag() -  L<Imager::ImageTypes/addtag()> - add image tags
4389
4390 align_string() - L<Imager::Draw/align_string()> - draw text aligned on a
4391 point
4392
4393 arc() - L<Imager::Draw/arc()> - draw a filled arc
4394
4395 bits() - L<Imager::ImageTypes/bits()> - number of bits per sample for the
4396 image
4397
4398 box() - L<Imager::Draw/box()> - draw a filled or outline box.
4399
4400 circle() - L<Imager::Draw/circle()> - draw a filled circle
4401
4402 close_log() - L<Imager::ImageTypes/close_log()> - close the Imager
4403 debugging log.
4404
4405 colorcount() - L<Imager::ImageTypes/colorcount()> - the number of
4406 colors in an image's palette (paletted images only)
4407
4408 combine() - L<Imager::Transformations/combine()> - combine channels
4409 from one or more images.
4410
4411 combines() - L<Imager::Draw/combines()> - return a list of the
4412 different combine type keywords
4413
4414 compose() - L<Imager::Transformations/compose()> - compose one image
4415 over another.
4416
4417 convert() - L<Imager::Transformations/convert()> - transform the color
4418 space
4419
4420 copy() - L<Imager::Transformations/copy()> - make a duplicate of an
4421 image
4422
4423 crop() - L<Imager::Transformations/crop()> - extract part of an image
4424
4425 def_guess_type() - L<Imager::Files/def_guess_type()> - default function
4426 used to guess the output file format based on the output file name
4427
4428 deltag() -  L<Imager::ImageTypes/deltag()> - delete image tags
4429
4430 difference() - L<Imager::Filters/difference()> - produce a difference
4431 images from two input images.
4432
4433 errstr() - L</errstr()> - the error from the last failed operation.
4434
4435 filter() - L<Imager::Filters/filter()> - image filtering
4436
4437 findcolor() - L<Imager::ImageTypes/findcolor()> - search the image
4438 palette, if it has one
4439
4440 flip() - L<Imager::Transformations/flip()> - flip an image, vertically,
4441 horizontally
4442
4443 flood_fill() - L<Imager::Draw/flood_fill()> - fill an enclosed or same
4444 color area
4445
4446 getchannels() - L<Imager::ImageTypes/getchannels()> - the number of
4447 samples per pixel for an image
4448
4449 getcolorcount() - L<Imager::ImageTypes/getcolorcount()> - the number of
4450 different colors used by an image (works for direct color images)
4451
4452 getcolors() - L<Imager::ImageTypes/getcolors()> - get colors from the image
4453 palette, if it has one
4454
4455 getcolorusage() - L<Imager::ImageTypes/getcolorusage()>
4456
4457 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash()>
4458
4459 get_file_limits() - L<Imager::Files/get_file_limits()>
4460
4461 getheight() - L<Imager::ImageTypes/getheight()> - height of the image in
4462 pixels
4463
4464 getmask() - L<Imager::ImageTypes/getmask()> - write mask for the image
4465
4466 getpixel() - L<Imager::Draw/getpixel()> - retrieve one or more pixel
4467 colors
4468
4469 getsamples() - L<Imager::Draw/getsamples()> - retrieve samples from a
4470 row or partial row of pixels.
4471
4472 getscanline() - L<Imager::Draw/getscanline()> - retrieve colors for a
4473 row or partial row of pixels.
4474
4475 getwidth() - L<Imager::ImageTypes/getwidth()> - width of the image in
4476 pixels.
4477
4478 img_set() - L<Imager::ImageTypes/img_set()> - re-use an Imager object
4479 for a new image.
4480
4481 init() - L<Imager::ImageTypes/init()>
4482
4483 is_bilevel() - L<Imager::ImageTypes/is_bilevel()> - returns whether
4484 image write functions should write the image in their bilevel (blank
4485 and white, no gray levels) format
4486
4487 is_logging() L<Imager::ImageTypes/is_logging()> - test if the debug
4488 log is active.
4489
4490 line() - L<Imager::Draw/line()> - draw an interval
4491
4492 load_plugin() - L<Imager::Filters/load_plugin()>
4493
4494 log() - L<Imager::ImageTypes/log()> - send a message to the debugging
4495 log.
4496
4497 make_palette() - L<Imager::ImageTypes/make_palette()> - produce a
4498 color palette from one or more input images.
4499
4500 map() - L<Imager::Transformations/map()> - remap color
4501 channel values
4502
4503 masked() -  L<Imager::ImageTypes/masked()> - make a masked image
4504
4505 matrix_transform() - L<Imager::Engines/matrix_transform()>
4506
4507 maxcolors() - L<Imager::ImageTypes/maxcolors()>
4508
4509 NC() - L<Imager::Handy/NC()>
4510
4511 NCF() - L<Imager::Handy/NCF()>
4512
4513 new() - L<Imager::ImageTypes/new()>
4514
4515 newcolor() - L<Imager::Handy/newcolor()>
4516
4517 newcolour() - L<Imager::Handy/newcolour()>
4518
4519 newfont() - L<Imager::Handy/newfont()>
4520
4521 NF() - L<Imager::Handy/NF()>
4522
4523 open() - L<Imager::Files/read()> - an alias for read()
4524
4525 open_log() - L<Imager::ImageTypes/open_log()> - open the debug log.
4526
4527 =for stopwords IPTC
4528
4529 parseiptc() - L<Imager::Files/parseiptc()> - parse IPTC data from a JPEG
4530 image
4531
4532 paste() - L<Imager::Transformations/paste()> - draw an image onto an
4533 image
4534
4535 polygon() - L<Imager::Draw/polygon()>
4536
4537 polyline() - L<Imager::Draw/polyline()>
4538
4539 preload() - L<Imager::Files/preload()>
4540
4541 read() - L<Imager::Files/read()> - read a single image from an image file
4542
4543 read_multi() - L<Imager::Files/read_multi()> - read multiple images from an image
4544 file
4545
4546 read_types() - L<Imager::Files/read_types()> - list image types Imager
4547 can read.
4548
4549 register_filter() - L<Imager::Filters/register_filter()>
4550
4551 register_reader() - L<Imager::Files/register_reader()>
4552
4553 register_writer() - L<Imager::Files/register_writer()>
4554
4555 rotate() - L<Imager::Transformations/rotate()>
4556
4557 rubthrough() - L<Imager::Transformations/rubthrough()> - draw an image
4558 onto an image and use the alpha channel
4559
4560 scale() - L<Imager::Transformations/scale()>
4561
4562 scale_calculate() - L<Imager::Transformations/scale_calculate()>
4563
4564 scaleX() - L<Imager::Transformations/scaleX()>
4565
4566 scaleY() - L<Imager::Transformations/scaleY()>
4567
4568 setcolors() - L<Imager::ImageTypes/setcolors()> - set palette colors
4569 in a paletted image
4570
4571 set_file_limits() - L<Imager::Files/set_file_limits()>
4572
4573 setmask() - L<Imager::ImageTypes/setmask()>
4574
4575 setpixel() - L<Imager::Draw/setpixel()>
4576
4577 setsamples() - L<Imager::Draw/setsamples()>
4578
4579 setscanline() - L<Imager::Draw/setscanline()>
4580
4581 settag() - L<Imager::ImageTypes/settag()>
4582
4583 string() - L<Imager::Draw/string()> - draw text on an image
4584
4585 tags() -  L<Imager::ImageTypes/tags()> - fetch image tags
4586
4587 to_paletted() -  L<Imager::ImageTypes/to_paletted()>
4588
4589 to_rgb16() - L<Imager::ImageTypes/to_rgb16()>
4590
4591 to_rgb8() - L<Imager::ImageTypes/to_rgb8()>
4592
4593 to_rgb_double() - L<Imager::ImageTypes/to_rgb_double()> - convert to
4594 double per sample image.
4595
4596 transform() - L<Imager::Engines/"transform()">
4597
4598 transform2() - L<Imager::Engines/"transform2()">
4599
4600 type() -  L<Imager::ImageTypes/type()> - type of image (direct vs paletted)
4601
4602 unload_plugin() - L<Imager::Filters/unload_plugin()>
4603
4604 virtual() - L<Imager::ImageTypes/virtual()> - whether the image has it's own
4605 data
4606
4607 write() - L<Imager::Files/write()> - write an image to a file
4608
4609 write_multi() - L<Imager::Files/write_multi()> - write multiple image to an image
4610 file.
4611
4612 write_types() - L<Imager::Files/read_types()> - list image types Imager
4613 can write.
4614
4615 =head1 CONCEPT INDEX
4616
4617 animated GIF - L<Imager::Files/"Writing an animated GIF">
4618
4619 aspect ratio - C<i_xres>, C<i_yres>, C<i_aspect_only> in
4620 L<Imager::ImageTypes/"Common Tags">.
4621
4622 blend - alpha blending one image onto another
4623 L<Imager::Transformations/rubthrough()>
4624
4625 blur - L<Imager::Filters/gaussian>, L<Imager::Filters/conv>
4626
4627 boxes, drawing - L<Imager::Draw/box()>
4628
4629 changes between image - L<Imager::Filters/"Image Difference">
4630
4631 channels, combine into one image - L<Imager::Transformations/combine()>
4632
4633 color - L<Imager::Color>
4634
4635 color names - L<Imager::Color>, L<Imager::Color::Table>
4636
4637 combine modes - L<Imager::Draw/"Combine Types">
4638
4639 compare images - L<Imager::Filters/"Image Difference">
4640
4641 contrast - L<Imager::Filters/contrast>, L<Imager::Filters/autolevels>
4642
4643 convolution - L<Imager::Filters/conv>
4644
4645 cropping - L<Imager::Transformations/crop()>
4646
4647 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4648
4649 C<diff> images - L<Imager::Filters/"Image Difference">
4650
4651 dpi - C<i_xres>, C<i_yres> in L<Imager::ImageTypes/"Common Tags">,
4652 L<Imager::Cookbook/"Image spatial resolution">
4653
4654 drawing boxes - L<Imager::Draw/box()>
4655
4656 drawing lines - L<Imager::Draw/line()>
4657
4658 drawing text - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>
4659
4660 error message - L</"ERROR HANDLING">
4661
4662 files, font - L<Imager::Font>
4663
4664 files, image - L<Imager::Files>
4665
4666 filling, types of fill - L<Imager::Fill>
4667
4668 filling, boxes - L<Imager::Draw/box()>
4669
4670 filling, flood fill - L<Imager::Draw/flood_fill()>
4671
4672 flood fill - L<Imager::Draw/flood_fill()>
4673
4674 fonts - L<Imager::Font>
4675
4676 fonts, drawing with - L<Imager::Draw/string()>,
4677 L<Imager::Draw/align_string()>, L<Imager::Font::Wrap>
4678
4679 fonts, metrics - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4680
4681 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4682
4683 fountain fill - L<Imager::Fill/"Fountain fills">,
4684 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4685 L<Imager::Filters/gradgen>
4686
4687 GIF files - L<Imager::Files/"GIF">
4688
4689 GIF files, animated - L<Imager::Files/"Writing an animated GIF">
4690
4691 gradient fill - L<Imager::Fill/"Fountain fills">,
4692 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4693 L<Imager::Filters/gradgen>
4694
4695 gray scale, convert image to - L<Imager::Transformations/convert()>
4696
4697 gaussian blur - L<Imager::Filters/gaussian>
4698
4699 hatch fills - L<Imager::Fill/"Hatched fills">
4700
4701 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4702
4703 invert image - L<Imager::Filters/hardinvert>,
4704 L<Imager::Filters/hardinvertall>
4705
4706 JPEG - L<Imager::Files/"JPEG">
4707
4708 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4709
4710 lines, drawing - L<Imager::Draw/line()>
4711
4712 matrix - L<Imager::Matrix2d>,
4713 L<Imager::Engines/"Matrix Transformations">,
4714 L<Imager::Font/transform()>
4715
4716 metadata, image - L<Imager::ImageTypes/"Tags">
4717
4718 mosaic - L<Imager::Filters/mosaic>
4719
4720 noise, filter - L<Imager::Filters/noise>
4721
4722 noise, rendered - L<Imager::Filters/turbnoise>,
4723 L<Imager::Filters/radnoise>
4724
4725 paste - L<Imager::Transformations/paste()>,
4726 L<Imager::Transformations/rubthrough()>
4727
4728 pseudo-color image - L<Imager::ImageTypes/to_paletted()>,
4729 L<Imager::ImageTypes/new()>
4730
4731 =for stopwords posterize
4732
4733 posterize - L<Imager::Filters/postlevels>
4734
4735 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
4736
4737 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
4738
4739 rectangles, drawing - L<Imager::Draw/box()>
4740
4741 resizing an image - L<Imager::Transformations/scale()>,
4742 L<Imager::Transformations/crop()>
4743
4744 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4745
4746 saving an image - L<Imager::Files>
4747
4748 scaling - L<Imager::Transformations/scale()>
4749
4750 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4751
4752 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4753
4754 size, image - L<Imager::ImageTypes/getwidth()>,
4755 L<Imager::ImageTypes/getheight()>
4756
4757 size, text - L<Imager::Font/bounding_box()>
4758
4759 tags, image metadata - L<Imager::ImageTypes/"Tags">
4760
4761 text, drawing - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>,
4762 L<Imager::Font::Wrap>
4763
4764 text, wrapping text in an area - L<Imager::Font::Wrap>
4765
4766 text, measuring - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4767
4768 tiles, color - L<Imager::Filters/mosaic>
4769
4770 transparent images - L<Imager::ImageTypes>,
4771 L<Imager::Cookbook/"Transparent PNG">
4772
4773 =for stopwords unsharp
4774
4775 unsharp mask - L<Imager::Filters/unsharpmask>
4776
4777 watermark - L<Imager::Filters/watermark>
4778
4779 writing an image to a file - L<Imager::Files>
4780
4781 =head1 THREADS
4782
4783 Imager doesn't support perl threads.
4784
4785 Imager has limited code to prevent double frees if you create images,
4786 colors etc, and then create a thread, but has no code to prevent two
4787 threads entering Imager's error handling code, and none is likely to
4788 be added.
4789
4790 =head1 SUPPORT
4791
4792 The best place to get help with Imager is the mailing list.
4793
4794 To subscribe send a message with C<subscribe> in the body to:
4795
4796    imager-devel+request@molar.is
4797
4798 or use the form at:
4799
4800 =over
4801
4802 L<http://www.molar.is/en/lists/imager-devel/>
4803
4804 =back
4805
4806 where you can also find the mailing list archive.
4807
4808 You can report bugs by pointing your browser at:
4809
4810 =over
4811
4812 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4813
4814 =back
4815
4816 or by sending an email to:
4817
4818 =over
4819
4820 bug-Imager@rt.cpan.org
4821
4822 =back
4823
4824 Please remember to include the versions of Imager, perl, supporting
4825 libraries, and any relevant code.  If you have specific images that
4826 cause the problems, please include those too.
4827
4828 If you don't want to publish your email address on a mailing list you
4829 can use CPAN::Forum:
4830
4831   http://www.cpanforum.com/dist/Imager
4832
4833 You will need to register to post.
4834
4835 =head1 CONTRIBUTING TO IMAGER
4836
4837 =head2 Feedback
4838
4839 I like feedback.
4840
4841 If you like or dislike Imager, you can add a public review of Imager
4842 at CPAN Ratings:
4843
4844   http://cpanratings.perl.org/dist/Imager
4845
4846 =for stopwords Bitcard
4847
4848 This requires a Bitcard account (http://www.bitcard.org).
4849
4850 You can also send email to the maintainer below.
4851
4852 If you send me a bug report via email, it will be copied to Request
4853 Tracker.
4854
4855 =head2 Patches
4856
4857 I accept patches, preferably against the master branch in git.  Please
4858 include an explanation of the reason for why the patch is needed or
4859 useful.
4860
4861 Your patch should include regression tests where possible, otherwise
4862 it will be delayed until I get a chance to write them.
4863
4864 To browse Imager's git repository:
4865
4866   http://git.imager.perl.org/imager.git
4867
4868 or:
4869
4870   https://github.com/tonycoz/imager
4871
4872 To clone:
4873
4874   git clone git://git.imager.perl.org/imager.git
4875
4876 or:
4877
4878   git clone git://github.com/tonycoz/imager.git
4879
4880 =head1 AUTHOR
4881
4882 Tony Cook <tonyc@cpan.org> is the current maintainer for Imager.
4883
4884 Arnar M. Hrafnkelsson is the original author of Imager.
4885
4886 Many others have contributed to Imager, please see the C<README> for a
4887 complete list.
4888
4889 =head1 LICENSE
4890
4891 Imager is licensed under the same terms as perl itself.
4892
4893 =for stopwords
4894 makeblendedfont Fontforge
4895
4896 A test font, generated by the Debian packaged Fontforge,
4897 F<FT2/fontfiles/MMOne.pfb>, contains a Postscript operator definition
4898 copyrighted by Adobe.  See F<adobe.txt> in the source for license
4899 information.
4900
4901 =head1 SEE ALSO
4902
4903 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4904 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4905 L<Imager::Font>(3), L<Imager::Transformations>(3),
4906 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4907 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4908
4909 L<http://imager.perl.org/>
4910
4911 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4912
4913 Other perl imaging modules include:
4914
4915 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3),
4916 L<Prima::Image>, L<IPA>.
4917
4918 If you're trying to use Imager for array processing, you should
4919 probably using L<PDL>.
4920
4921 =cut