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