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