Imager.pm

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