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