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