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