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