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