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