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