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