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