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