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 %opts=(xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2656
2657   if (exists $opts{'box'}) {
2658     $opts{'xmin'} = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2659     $opts{'xmax'} = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2660     $opts{'ymin'} = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2661     $opts{'ymax'} = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2662   }
2663
2664   if ($opts{filled}) {
2665     my $color = $opts{'color'};
2666
2667     if (defined $color) {
2668       unless (ref $color &&
2669               (UNIVERSAL::isa($color, "Imager::Color")
2670                || UNIVERSAL::isa($color, "Imager::Color::Float"))) {
2671         $color = _color($color);
2672         unless ($color) {
2673           $self->{ERRSTR} = $Imager::ERRSTR;
2674           return;
2675         }
2676       }
2677     }
2678     else {
2679       $color = i_color_new(255,255,255,255);
2680     }
2681
2682     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2683                  $opts{ymax}, $color);
2684   }
2685   elsif ($opts{fill}) {
2686     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2687       # assume it's a hash ref
2688       require 'Imager/Fill.pm';
2689       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2690         $self->{ERRSTR} = $Imager::ERRSTR;
2691         return undef;
2692       }
2693     }
2694     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2695                 $opts{ymax},$opts{fill}{fill});
2696   }
2697   else {
2698     my $color = $opts{'color'};
2699     if (defined $color) {
2700       unless (ref $color &&
2701               (UNIVERSAL::isa($color, "Imager::Color")
2702                || UNIVERSAL::isa($color, "Imager::Color::Float"))) {
2703         $color = _color($color);
2704         unless ($color) {
2705           $self->{ERRSTR} = $Imager::ERRSTR;
2706           return;
2707         }
2708       }
2709     }
2710     else {
2711       $color = i_color_new(255, 255, 255, 255);
2712     }
2713     unless ($color) {
2714       $self->{ERRSTR} = $Imager::ERRSTR;
2715       return;
2716     }
2717     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2718           $color);
2719   }
2720   return $self;
2721 }
2722
2723 sub arc {
2724   my $self=shift;
2725   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2726   my $dflcl= [ 255, 255, 255, 255];
2727   my $good = 1;
2728   my %opts=
2729     (
2730      color=>$dflcl,
2731      'r'=>_min($self->getwidth(),$self->getheight())/3,
2732      'x'=>$self->getwidth()/2,
2733      'y'=>$self->getheight()/2,
2734      'd1'=>0, 'd2'=>361,
2735      filled => 1,
2736      @_,
2737     );
2738   if ($opts{aa}) {
2739     if ($opts{fill}) {
2740       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2741         # assume it's a hash ref
2742         require 'Imager/Fill.pm';
2743         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2744           $self->{ERRSTR} = $Imager::ERRSTR;
2745           return;
2746         }
2747       }
2748       i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2749                      $opts{'d2'}, $opts{fill}{fill});
2750     }
2751     elsif ($opts{filled}) {
2752       my $color = _color($opts{'color'});
2753       unless ($color) {
2754         $self->{ERRSTR} = $Imager::ERRSTR;
2755         return;
2756       }
2757       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2758         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2759                     $color);
2760       }
2761       else {
2762         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2763                  $opts{'d1'}, $opts{'d2'}, $color);
2764       }
2765     }
2766     else {
2767       my $color = _color($opts{'color'});
2768       if ($opts{d2} - $opts{d1} >= 360) {
2769         $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2770       }
2771       else {
2772         $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2773       }
2774     }
2775   }
2776   else {
2777     if ($opts{fill}) {
2778       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2779         # assume it's a hash ref
2780         require 'Imager/Fill.pm';
2781         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2782           $self->{ERRSTR} = $Imager::ERRSTR;
2783           return;
2784         }
2785       }
2786       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2787                   $opts{'d2'}, $opts{fill}{fill});
2788     }
2789     else {
2790       my $color = _color($opts{'color'});
2791       unless ($color) {
2792         $self->{ERRSTR} = $Imager::ERRSTR;
2793         return;
2794       }
2795       if ($opts{filled}) {
2796         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2797               $opts{'d1'}, $opts{'d2'}, $color);
2798       }
2799       else {
2800         if ($opts{d1} == 0 && $opts{d2} == 361) {
2801           $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2802         }
2803         else {
2804           $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2805         }
2806       }
2807     }
2808   }
2809   unless ($good) {
2810     $self->_set_error($self->_error_as_msg);
2811     return;
2812   }
2813
2814   return $self;
2815 }
2816
2817 # Draws a line from one point to the other
2818 # the endpoint is set if the endp parameter is set which it is by default.
2819 # to turn of the endpoint being set use endp=>0 when calling line.
2820
2821 sub line {
2822   my $self=shift;
2823   my $dflcl=i_color_new(0,0,0,0);
2824   my %opts=(color=>$dflcl,
2825             endp => 1,
2826             @_);
2827   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2828
2829   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2830   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2831
2832   my $color = _color($opts{'color'});
2833   unless ($color) {
2834     $self->{ERRSTR} = $Imager::ERRSTR;
2835     return;
2836   }
2837
2838   $opts{antialias} = $opts{aa} if defined $opts{aa};
2839   if ($opts{antialias}) {
2840     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2841               $color, $opts{endp});
2842   } else {
2843     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2844            $color, $opts{endp});
2845   }
2846   return $self;
2847 }
2848
2849 # Draws a line between an ordered set of points - It more or less just transforms this
2850 # into a list of lines.
2851
2852 sub polyline {
2853   my $self=shift;
2854   my ($pt,$ls,@points);
2855   my $dflcl=i_color_new(0,0,0,0);
2856   my %opts=(color=>$dflcl,@_);
2857
2858   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2859
2860   if (exists($opts{points})) { @points=@{$opts{points}}; }
2861   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2862     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2863     }
2864
2865 #  print Dumper(\@points);
2866
2867   my $color = _color($opts{'color'});
2868   unless ($color) {
2869     $self->{ERRSTR} = $Imager::ERRSTR;
2870     return;
2871   }
2872   $opts{antialias} = $opts{aa} if defined $opts{aa};
2873   if ($opts{antialias}) {
2874     for $pt(@points) {
2875       if (defined($ls)) {
2876         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2877       }
2878       $ls=$pt;
2879     }
2880   } else {
2881     for $pt(@points) {
2882       if (defined($ls)) {
2883         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2884       }
2885       $ls=$pt;
2886     }
2887   }
2888   return $self;
2889 }
2890
2891 sub polygon {
2892   my $self = shift;
2893   my ($pt,$ls,@points);
2894   my $dflcl = i_color_new(0,0,0,0);
2895   my %opts = (color=>$dflcl, @_);
2896
2897   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2898
2899   if (exists($opts{points})) {
2900     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2901     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2902   }
2903
2904   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2905     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2906   }
2907
2908   if ($opts{'fill'}) {
2909     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2910       # assume it's a hash ref
2911       require 'Imager/Fill.pm';
2912       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2913         $self->{ERRSTR} = $Imager::ERRSTR;
2914         return undef;
2915       }
2916     }
2917     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2918                     $opts{'fill'}{'fill'});
2919   }
2920   else {
2921     my $color = _color($opts{'color'});
2922     unless ($color) {
2923       $self->{ERRSTR} = $Imager::ERRSTR;
2924       return;
2925     }
2926     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2927   }
2928
2929   return $self;
2930 }
2931
2932
2933 # this the multipoint bezier curve
2934 # this is here more for testing that actual usage since
2935 # this is not a good algorithm.  Usually the curve would be
2936 # broken into smaller segments and each done individually.
2937
2938 sub polybezier {
2939   my $self=shift;
2940   my ($pt,$ls,@points);
2941   my $dflcl=i_color_new(0,0,0,0);
2942   my %opts=(color=>$dflcl,@_);
2943
2944   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2945
2946   if (exists $opts{points}) {
2947     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2948     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2949   }
2950
2951   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2952     $self->{ERRSTR}='Missing or invalid points.';
2953     return;
2954   }
2955
2956   my $color = _color($opts{'color'});
2957   unless ($color) {
2958     $self->{ERRSTR} = $Imager::ERRSTR;
2959     return;
2960   }
2961   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2962   return $self;
2963 }
2964
2965 sub flood_fill {
2966   my $self = shift;
2967   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2968   my $rc;
2969
2970   unless (exists $opts{'x'} && exists $opts{'y'}) {
2971     $self->{ERRSTR} = "missing seed x and y parameters";
2972     return undef;
2973   }
2974
2975   if ($opts{border}) {
2976     my $border = _color($opts{border});
2977     unless ($border) {
2978       $self->_set_error($Imager::ERRSTR);
2979       return;
2980     }
2981     if ($opts{fill}) {
2982       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2983         # assume it's a hash ref
2984         require Imager::Fill;
2985         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2986           $self->{ERRSTR} = $Imager::ERRSTR;
2987           return;
2988         }
2989       }
2990       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2991                                  $opts{fill}{fill}, $border);
2992     }
2993     else {
2994       my $color = _color($opts{'color'});
2995       unless ($color) {
2996         $self->{ERRSTR} = $Imager::ERRSTR;
2997         return;
2998       }
2999       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3000                                 $color, $border);
3001     }
3002     if ($rc) {
3003       return $self;
3004     }
3005     else {
3006       $self->{ERRSTR} = $self->_error_as_msg();
3007       return;
3008     }
3009   }
3010   else {
3011     if ($opts{fill}) {
3012       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3013         # assume it's a hash ref
3014         require 'Imager/Fill.pm';
3015         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3016           $self->{ERRSTR} = $Imager::ERRSTR;
3017           return;
3018         }
3019       }
3020       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3021     }
3022     else {
3023       my $color = _color($opts{'color'});
3024       unless ($color) {
3025         $self->{ERRSTR} = $Imager::ERRSTR;
3026         return;
3027       }
3028       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3029     }
3030     if ($rc) {
3031       return $self;
3032     }
3033     else {
3034       $self->{ERRSTR} = $self->_error_as_msg();
3035       return;
3036     }
3037   }
3038 }
3039
3040 sub setpixel {
3041   my ($self, %opts) = @_;
3042
3043   my $color = $opts{color};
3044   unless (defined $color) {
3045     $color = $self->{fg};
3046     defined $color or $color = NC(255, 255, 255);
3047   }
3048
3049   unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3050     $color = _color($color)
3051       or return undef;
3052   }
3053
3054   unless (exists $opts{'x'} && exists $opts{'y'}) {
3055     $self->{ERRSTR} = 'missing x and y parameters';
3056     return undef;
3057   }
3058
3059   my $x = $opts{'x'};
3060   my $y = $opts{'y'};
3061   if (ref $x && ref $y) {
3062     unless (@$x == @$y) {
3063       $self->{ERRSTR} = 'length of x and y mismatch';
3064       return;
3065     }
3066     my $set = 0;
3067     if ($color->isa('Imager::Color')) {
3068       for my $i (0..$#{$opts{'x'}}) {
3069         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3070           or ++$set;
3071       }
3072     }
3073     else {
3074       for my $i (0..$#{$opts{'x'}}) {
3075         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3076           or ++$set;
3077       }
3078     }
3079     $set or return;
3080     return $set;
3081   }
3082   else {
3083     if ($color->isa('Imager::Color')) {
3084       i_ppix($self->{IMG}, $x, $y, $color)
3085         and return;
3086     }
3087     else {
3088       i_ppixf($self->{IMG}, $x, $y, $color)
3089         and return;
3090     }
3091   }
3092
3093   $self;
3094 }
3095
3096 sub getpixel {
3097   my $self = shift;
3098
3099   my %opts = ( "type"=>'8bit', @_);
3100
3101   unless (exists $opts{'x'} && exists $opts{'y'}) {
3102     $self->{ERRSTR} = 'missing x and y parameters';
3103     return undef;
3104   }
3105
3106   my $x = $opts{'x'};
3107   my $y = $opts{'y'};
3108   if (ref $x && ref $y) {
3109     unless (@$x == @$y) {
3110       $self->{ERRSTR} = 'length of x and y mismatch';
3111       return undef;
3112     }
3113     my @result;
3114     if ($opts{"type"} eq '8bit') {
3115       for my $i (0..$#{$opts{'x'}}) {
3116         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3117       }
3118     }
3119     else {
3120       for my $i (0..$#{$opts{'x'}}) {
3121         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3122       }
3123     }
3124     return wantarray ? @result : \@result;
3125   }
3126   else {
3127     if ($opts{"type"} eq '8bit') {
3128       return i_get_pixel($self->{IMG}, $x, $y);
3129     }
3130     else {
3131       return i_gpixf($self->{IMG}, $x, $y);
3132     }
3133   }
3134
3135   $self;
3136 }
3137
3138 sub getscanline {
3139   my $self = shift;
3140   my %opts = ( type => '8bit', x=>0, @_);
3141
3142   $self->_valid_image or return;
3143
3144   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3145
3146   unless (defined $opts{'y'}) {
3147     $self->_set_error("missing y parameter");
3148     return;
3149   }
3150
3151   if ($opts{type} eq '8bit') {
3152     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3153                   $opts{'y'});
3154   }
3155   elsif ($opts{type} eq 'float') {
3156     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3157                   $opts{'y'});
3158   }
3159   elsif ($opts{type} eq 'index') {
3160     unless (i_img_type($self->{IMG})) {
3161       $self->_set_error("type => index only valid on paletted images");
3162       return;
3163     }
3164     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3165                   $opts{'y'});
3166   }
3167   else {
3168     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3169     return;
3170   }
3171 }
3172
3173 sub setscanline {
3174   my $self = shift;
3175   my %opts = ( x=>0, @_);
3176
3177   $self->_valid_image or return;
3178
3179   unless (defined $opts{'y'}) {
3180     $self->_set_error("missing y parameter");
3181     return;
3182   }
3183
3184   if (!$opts{type}) {
3185     if (ref $opts{pixels} && @{$opts{pixels}}) {
3186       # try to guess the type
3187       if ($opts{pixels}[0]->isa('Imager::Color')) {
3188         $opts{type} = '8bit';
3189       }
3190       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3191         $opts{type} = 'float';
3192       }
3193       else {
3194         $self->_set_error("missing type parameter and could not guess from pixels");
3195         return;
3196       }
3197     }
3198     else {
3199       # default
3200       $opts{type} = '8bit';
3201     }
3202   }
3203
3204   if ($opts{type} eq '8bit') {
3205     if (ref $opts{pixels}) {
3206       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3207     }
3208     else {
3209       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3210     }
3211   }
3212   elsif ($opts{type} eq 'float') {
3213     if (ref $opts{pixels}) {
3214       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3215     }
3216     else {
3217       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3218     }
3219   }
3220   elsif ($opts{type} eq 'index') {
3221     if (ref $opts{pixels}) {
3222       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3223     }
3224     else {
3225       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3226     }
3227   }
3228   else {
3229     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3230     return;
3231   }
3232 }
3233
3234 sub getsamples {
3235   my $self = shift;
3236   my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3237
3238   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3239
3240   unless (defined $opts{'y'}) {
3241     $self->_set_error("missing y parameter");
3242     return;
3243   }
3244
3245   unless ($opts{channels}) {
3246     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3247   }
3248
3249   if ($opts{target}) {
3250     my $target = $opts{target};
3251     my $offset = $opts{offset};
3252     if ($opts{type} eq '8bit') {
3253       my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3254                             $opts{y}, @{$opts{channels}})
3255         or return;
3256       @{$target}{$offset .. $offset + @samples - 1} = @samples;
3257       return scalar(@samples);
3258     }
3259     elsif ($opts{type} eq 'float') {
3260       my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3261                              $opts{y}, @{$opts{channels}});
3262       @{$target}{$offset .. $offset + @samples - 1} = @samples;
3263       return scalar(@samples);
3264     }
3265     elsif ($opts{type} =~ /^(\d+)bit$/) {
3266       my $bits = $1;
3267
3268       my @data;
3269       my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3270                                $opts{y}, $bits, $target,
3271                                $offset, @{$opts{channels}});
3272       unless (defined $count) {
3273         $self->_set_error(Imager->_error_as_msg);
3274         return;
3275       }
3276
3277       return $count;
3278     }
3279     else {
3280       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3281       return;
3282     }
3283   }
3284   else {
3285     if ($opts{type} eq '8bit') {
3286       return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3287                      $opts{y}, @{$opts{channels}});
3288     }
3289     elsif ($opts{type} eq 'float') {
3290       return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3291                       $opts{y}, @{$opts{channels}});
3292     }
3293     elsif ($opts{type} =~ /^(\d+)bit$/) {
3294       my $bits = $1;
3295
3296       my @data;
3297       i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3298                    $opts{y}, $bits, \@data, 0, @{$opts{channels}})
3299         or return;
3300       return @data;
3301     }
3302     else {
3303       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3304       return;
3305     }
3306   }
3307 }
3308
3309 sub setsamples {
3310   my $self = shift;
3311   my %opts = ( x => 0, offset => 0, @_ );
3312
3313   unless ($self->{IMG}) {
3314     $self->_set_error('setsamples: empty input image');
3315     return;
3316   }
3317
3318   unless(defined $opts{data} && ref $opts{data}) {
3319     $self->_set_error('setsamples: data parameter missing or invalid');
3320     return;
3321   }
3322
3323   unless ($opts{channels}) {
3324     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3325   }
3326
3327   unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) {
3328     $self->_set_error('setsamples: type parameter missing or invalid');
3329     return;
3330   }
3331   my $bits = $1;
3332
3333   unless (defined $opts{width}) {
3334     $opts{width} = $self->getwidth() - $opts{x};
3335   }
3336
3337   my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3338                            $opts{channels}, $opts{data}, $opts{offset},
3339                            $opts{width});
3340   unless (defined $count) {
3341     $self->_set_error(Imager->_error_as_msg);
3342     return;
3343   }
3344
3345   return $count;
3346 }
3347
3348 # make an identity matrix of the given size
3349 sub _identity {
3350   my ($size) = @_;
3351
3352   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3353   for my $c (0 .. ($size-1)) {
3354     $matrix->[$c][$c] = 1;
3355   }
3356   return $matrix;
3357 }
3358
3359 # general function to convert an image
3360 sub convert {
3361   my ($self, %opts) = @_;
3362   my $matrix;
3363
3364   unless (defined wantarray) {
3365     my @caller = caller;
3366     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3367     return;
3368   }
3369
3370   # the user can either specify a matrix or preset
3371   # the matrix overrides the preset
3372   if (!exists($opts{matrix})) {
3373     unless (exists($opts{preset})) {
3374       $self->{ERRSTR} = "convert() needs a matrix or preset";
3375       return;
3376     }
3377     else {
3378       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3379         # convert to greyscale, keeping the alpha channel if any
3380         if ($self->getchannels == 3) {
3381           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3382         }
3383         elsif ($self->getchannels == 4) {
3384           # preserve the alpha channel
3385           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3386                       [ 0,     0,     0,     1 ] ];
3387         }
3388         else {
3389           # an identity
3390           $matrix = _identity($self->getchannels);
3391         }
3392       }
3393       elsif ($opts{preset} eq 'noalpha') {
3394         # strip the alpha channel
3395         if ($self->getchannels == 2 or $self->getchannels == 4) {
3396           $matrix = _identity($self->getchannels);
3397           pop(@$matrix); # lose the alpha entry
3398         }
3399         else {
3400           $matrix = _identity($self->getchannels);
3401         }
3402       }
3403       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3404         # extract channel 0
3405         $matrix = [ [ 1 ] ];
3406       }
3407       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3408         $matrix = [ [ 0, 1 ] ];
3409       }
3410       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3411         $matrix = [ [ 0, 0, 1 ] ];
3412       }
3413       elsif ($opts{preset} eq 'alpha') {
3414         if ($self->getchannels == 2 or $self->getchannels == 4) {
3415           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3416         }
3417         else {
3418           # the alpha is just 1 <shrug>
3419           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3420         }
3421       }
3422       elsif ($opts{preset} eq 'rgb') {
3423         if ($self->getchannels == 1) {
3424           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3425         }
3426         elsif ($self->getchannels == 2) {
3427           # preserve the alpha channel
3428           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3429         }
3430         else {
3431           $matrix = _identity($self->getchannels);
3432         }
3433       }
3434       elsif ($opts{preset} eq 'addalpha') {
3435         if ($self->getchannels == 1) {
3436           $matrix = _identity(2);
3437         }
3438         elsif ($self->getchannels == 3) {
3439           $matrix = _identity(4);
3440         }
3441         else {
3442           $matrix = _identity($self->getchannels);
3443         }
3444       }
3445       else {
3446         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3447         return undef;
3448       }
3449     }
3450   }
3451   else {
3452     $matrix = $opts{matrix};
3453   }
3454
3455   my $new = Imager->new;
3456   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3457   unless ($new->{IMG}) {
3458     # most likely a bad matrix
3459     $self->{ERRSTR} = _error_as_msg();
3460     return undef;
3461   }
3462   return $new;
3463 }
3464
3465
3466 # general function to map an image through lookup tables
3467
3468 sub map {
3469   my ($self, %opts) = @_;
3470   my @chlist = qw( red green blue alpha );
3471
3472   if (!exists($opts{'maps'})) {
3473     # make maps from channel maps
3474     my $chnum;
3475     for $chnum (0..$#chlist) {
3476       if (exists $opts{$chlist[$chnum]}) {
3477         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3478       } elsif (exists $opts{'all'}) {
3479         $opts{'maps'}[$chnum] = $opts{'all'};
3480       }
3481     }
3482   }
3483   if ($opts{'maps'} and $self->{IMG}) {
3484     i_map($self->{IMG}, $opts{'maps'} );
3485   }
3486   return $self;
3487 }
3488
3489 sub difference {
3490   my ($self, %opts) = @_;
3491
3492   defined $opts{mindist} or $opts{mindist} = 0;
3493
3494   defined $opts{other}
3495     or return $self->_set_error("No 'other' parameter supplied");
3496   defined $opts{other}{IMG}
3497     or return $self->_set_error("No image data in 'other' image");
3498
3499   $self->{IMG}
3500     or return $self->_set_error("No image data");
3501
3502   my $result = Imager->new;
3503   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3504                                 $opts{mindist})
3505     or return $self->_set_error($self->_error_as_msg());
3506
3507   return $result;
3508 }
3509
3510 # destructive border - image is shrunk by one pixel all around
3511
3512 sub border {
3513   my ($self,%opts)=@_;
3514   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3515   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3516 }
3517
3518
3519 # Get the width of an image
3520
3521 sub getwidth {
3522   my $self = shift;
3523   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3524   return (i_img_info($self->{IMG}))[0];
3525 }
3526
3527 # Get the height of an image
3528
3529 sub getheight {
3530   my $self = shift;
3531   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3532   return (i_img_info($self->{IMG}))[1];
3533 }
3534
3535 # Get number of channels in an image
3536
3537 sub getchannels {
3538   my $self = shift;
3539   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3540   return i_img_getchannels($self->{IMG});
3541 }
3542
3543 # Get channel mask
3544
3545 sub getmask {
3546   my $self = shift;
3547   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3548   return i_img_getmask($self->{IMG});
3549 }
3550
3551 # Set channel mask
3552
3553 sub setmask {
3554   my $self = shift;
3555   my %opts = @_;
3556   if (!defined($self->{IMG})) {
3557     $self->{ERRSTR} = 'image is empty';
3558     return undef;
3559   }
3560   unless (defined $opts{mask}) {
3561     $self->_set_error("mask parameter required");
3562     return;
3563   }
3564   i_img_setmask( $self->{IMG} , $opts{mask} );
3565
3566   1;
3567 }
3568
3569 # Get number of colors in an image
3570
3571 sub getcolorcount {
3572   my $self=shift;
3573   my %opts=('maxcolors'=>2**30,@_);
3574   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3575   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3576   return ($rc==-1? undef : $rc);
3577 }
3578
3579 # Returns a reference to a hash. The keys are colour named (packed) and the
3580 # values are the number of pixels in this colour.
3581 sub getcolorusagehash {
3582   my $self = shift;
3583
3584   my %opts = ( maxcolors => 2**30, @_ );
3585   my $max_colors = $opts{maxcolors};
3586   unless (defined $max_colors && $max_colors > 0) {
3587     $self->_set_error('maxcolors must be a positive integer');
3588     return;
3589   }
3590
3591   unless (defined $self->{IMG}) {
3592     $self->_set_error('empty input image');
3593     return;
3594   }
3595
3596   my $channels= $self->getchannels;
3597   # We don't want to look at the alpha channel, because some gifs using it
3598   # doesn't define it for every colour (but only for some)
3599   $channels -= 1 if $channels == 2 or $channels == 4;
3600   my %color_use;
3601   my $height = $self->getheight;
3602   for my $y (0 .. $height - 1) {
3603     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3604     while (length $colors) {
3605       $color_use{ substr($colors, 0, $channels, '') }++;
3606     }
3607     keys %color_use > $max_colors
3608       and return;
3609   }
3610   return \%color_use;
3611 }
3612
3613 # This will return a ordered array of the colour usage. Kind of the sorted
3614 # version of the values of the hash returned by getcolorusagehash.
3615 # You might want to add safety checks and change the names, etc...
3616 sub getcolorusage {
3617   my $self = shift;
3618
3619   my %opts = ( maxcolors => 2**30, @_ );
3620   my $max_colors = $opts{maxcolors};
3621   unless (defined $max_colors && $max_colors > 0) {
3622     $self->_set_error('maxcolors must be a positive integer');
3623     return;
3624   }
3625
3626   unless (defined $self->{IMG}) {
3627     $self->_set_error('empty input image');
3628     return undef;
3629   }
3630
3631   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3632 }
3633
3634 # draw string to an image
3635
3636 sub string {
3637   my $self = shift;
3638   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3639
3640   my %input=('x'=>0, 'y'=>0, @_);
3641   defined($input{string}) or $input{string} = $input{text};
3642
3643   unless(defined $input{string}) {
3644     $self->{ERRSTR}="missing required parameter 'string'";
3645     return;
3646   }
3647
3648   unless($input{font}) {
3649     $self->{ERRSTR}="missing required parameter 'font'";
3650     return;
3651   }
3652
3653   unless ($input{font}->draw(image=>$self, %input)) {
3654     return;
3655   }
3656
3657   return $self;
3658 }
3659
3660 sub align_string {
3661   my $self = shift;
3662
3663   my $img;
3664   if (ref $self) {
3665     unless ($self->{IMG}) {
3666       $self->{ERRSTR}='empty input image';
3667       return;
3668     }
3669     $img = $self;
3670   }
3671   else {
3672     $img = undef;
3673   }
3674
3675   my %input=('x'=>0, 'y'=>0, @_);
3676   defined $input{string}
3677     or $input{string} = $input{text};
3678
3679   unless(exists $input{string}) {
3680     $self->_set_error("missing required parameter 'string'");
3681     return;
3682   }
3683
3684   unless($input{font}) {
3685     $self->_set_error("missing required parameter 'font'");
3686     return;
3687   }
3688
3689   my @result;
3690   unless (@result = $input{font}->align(image=>$img, %input)) {
3691     return;
3692   }
3693
3694   return wantarray ? @result : $result[0];
3695 }
3696
3697 my @file_limit_names = qw/width height bytes/;
3698
3699 sub set_file_limits {
3700   shift;
3701
3702   my %opts = @_;
3703   my %values;
3704
3705   if ($opts{reset}) {
3706     @values{@file_limit_names} = (0) x @file_limit_names;
3707   }
3708   else {
3709     @values{@file_limit_names} = i_get_image_file_limits();
3710   }
3711
3712   for my $key (keys %values) {
3713     defined $opts{$key} and $values{$key} = $opts{$key};
3714   }
3715
3716   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3717 }
3718
3719 sub get_file_limits {
3720   i_get_image_file_limits();
3721 }
3722
3723 # Shortcuts that can be exported
3724
3725 sub newcolor { Imager::Color->new(@_); }
3726 sub newfont  { Imager::Font->new(@_); }
3727 sub NCF { Imager::Color::Float->new(@_) }
3728
3729 *NC=*newcolour=*newcolor;
3730 *NF=*newfont;
3731
3732 *open=\&read;
3733 *circle=\&arc;
3734
3735
3736 #### Utility routines
3737
3738 sub errstr {
3739   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3740 }
3741
3742 sub _set_error {
3743   my ($self, $msg) = @_;
3744
3745   if (ref $self) {
3746     $self->{ERRSTR} = $msg;
3747   }
3748   else {
3749     $ERRSTR = $msg;
3750   }
3751   return;
3752 }
3753
3754 # Default guess for the type of an image from extension
3755
3756 sub def_guess_type {
3757   my $name=lc(shift);
3758   my $ext;
3759   $ext=($name =~ m/\.([^\.]+)$/)[0];
3760   return 'tiff' if ($ext =~ m/^tiff?$/);
3761   return 'jpeg' if ($ext =~ m/^jpe?g$/);
3762   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
3763   return 'png'  if ($ext eq "png");
3764   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
3765   return 'tga'  if ($ext eq "tga");
3766   return 'sgi'  if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
3767   return 'gif'  if ($ext eq "gif");
3768   return 'raw'  if ($ext eq "raw");
3769   return lc $ext; # best guess
3770   return ();
3771 }
3772
3773 sub combines {
3774   return @combine_types;
3775 }
3776
3777 # get the minimum of a list
3778
3779 sub _min {
3780   my $mx=shift;
3781   for(@_) { if ($_<$mx) { $mx=$_; }}
3782   return $mx;
3783 }
3784
3785 # get the maximum of a list
3786
3787 sub _max {
3788   my $mx=shift;
3789   for(@_) { if ($_>$mx) { $mx=$_; }}
3790   return $mx;
3791 }
3792
3793 # string stuff for iptc headers
3794
3795 sub _clean {
3796   my($str)=$_[0];
3797   $str = substr($str,3);
3798   $str =~ s/[\n\r]//g;
3799   $str =~ s/\s+/ /g;
3800   $str =~ s/^\s//;
3801   $str =~ s/\s$//;
3802   return $str;
3803 }
3804
3805 # A little hack to parse iptc headers.
3806
3807 sub parseiptc {
3808   my $self=shift;
3809   my(@sar,$item,@ar);
3810   my($caption,$photogr,$headln,$credit);
3811
3812   my $str=$self->{IPTCRAW};
3813
3814   defined $str
3815     or return;
3816
3817   @ar=split(/8BIM/,$str);
3818
3819   my $i=0;
3820   foreach (@ar) {
3821     if (/^\004\004/) {
3822       @sar=split(/\034\002/);
3823       foreach $item (@sar) {
3824         if ($item =~ m/^x/) {
3825           $caption = _clean($item);
3826           $i++;
3827         }
3828         if ($item =~ m/^P/) {
3829           $photogr = _clean($item);
3830           $i++;
3831         }
3832         if ($item =~ m/^i/) {
3833           $headln = _clean($item);
3834           $i++;
3835         }
3836         if ($item =~ m/^n/) {
3837           $credit = _clean($item);
3838           $i++;
3839         }
3840       }
3841     }
3842   }
3843   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3844 }
3845
3846 sub Inline {
3847   my ($lang) = @_;
3848
3849   $lang eq 'C'
3850     or die "Only C language supported";
3851
3852   require Imager::ExtUtils;
3853   return Imager::ExtUtils->inline_config;
3854 }
3855
3856 # threads shouldn't try to close raw Imager objects
3857 sub Imager::ImgRaw::CLONE_SKIP { 1 }
3858
3859 # backward compatibility for %formats
3860 package Imager::FORMATS;
3861 use strict;
3862 use constant IX_FORMATS => 0;
3863 use constant IX_LIST => 1;
3864 use constant IX_INDEX => 2;
3865 use constant IX_CLASSES => 3;
3866
3867 sub TIEHASH {
3868   my ($class, $formats, $classes) = @_;
3869
3870   return bless [ $formats, [ ], 0, $classes ], $class;
3871 }
3872
3873 sub _check {
3874   my ($self, $key) = @_;
3875
3876   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
3877   my $value;
3878   if (eval { require $file; 1 }) {
3879     $value = 1;
3880   }
3881   else {
3882     $value = undef;
3883   }
3884   $self->[IX_FORMATS]{$key} = $value;
3885
3886   return $value;
3887 }
3888
3889 sub FETCH {
3890   my ($self, $key) = @_;
3891
3892   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
3893
3894   $self->[IX_CLASSES]{$key} or return undef;
3895
3896   return $self->_check($key);
3897 }
3898
3899 sub STORE {
3900   die "%Imager::formats is not user monifiable";
3901 }
3902
3903 sub DELETE {
3904   die "%Imager::formats is not user monifiable";
3905 }
3906
3907 sub CLEAR {
3908   die "%Imager::formats is not user monifiable";
3909 }
3910
3911 sub EXISTS {
3912   my ($self, $key) = @_;
3913
3914   if (exists $self->[IX_FORMATS]{$key}) {
3915     my $value = $self->[IX_FORMATS]{$key}
3916       or return;
3917     return 1;
3918   }
3919
3920   $self->_check($key) or return 1==0;
3921
3922   return 1==1;
3923 }
3924
3925 sub FIRSTKEY {
3926   my ($self) = @_;
3927
3928   unless (@{$self->[IX_LIST]}) {
3929     # full populate it
3930     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
3931       keys %{$self->[IX_FORMATS]};
3932
3933     for my $key (keys %{$self->[IX_CLASSES]}) {
3934       $self->[IX_FORMATS]{$key} and next;
3935       $self->_check($key)
3936         and push @{$self->[IX_LIST]}, $key;
3937     }
3938   }
3939
3940   @{$self->[IX_LIST]} or return;
3941   $self->[IX_INDEX] = 1;
3942   return $self->[IX_LIST][0];
3943 }
3944
3945 sub NEXTKEY {
3946   my ($self) = @_;
3947
3948   $self->[IX_INDEX] < @{$self->[IX_LIST]}
3949     or return;
3950
3951   return $self->[IX_LIST][$self->[IX_INDEX]++];
3952 }
3953
3954 sub SCALAR {
3955   my ($self) = @_;
3956
3957   return scalar @{$self->[IX_LIST]};
3958 }
3959
3960 1;
3961 __END__
3962 # Below is the stub of documentation for your module. You better edit it!
3963
3964 =head1 NAME
3965
3966 Imager - Perl extension for Generating 24 bit Images
3967
3968 =head1 SYNOPSIS
3969
3970   # Thumbnail example
3971
3972   #!/usr/bin/perl -w
3973   use strict;
3974   use Imager;
3975
3976   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3977   my $file = shift;
3978
3979   my $format;
3980
3981   # see Imager::Files for information on the read() method
3982   my $im = Imager->new(file=>$file)
3983     or die Imager->errstr();
3984
3985   $file =~ s/\.[^.]*$//;
3986
3987   # Create smaller version
3988   # documented in Imager::Transformations
3989   my $thumb = $img->scale(scalefactor=>.3);
3990
3991   # Autostretch individual channels
3992   $thumb->filter(type=>'autolevels');
3993
3994   # try to save in one of these formats
3995   SAVE:
3996
3997   for $format ( qw( png gif jpeg tiff ppm ) ) {
3998     # Check if given format is supported
3999     if ($Imager::formats{$format}) {
4000       $file.="_low.$format";
4001       print "Storing image as: $file\n";
4002       # documented in Imager::Files
4003       $thumb->write(file=>$file) or
4004         die $thumb->errstr;
4005       last SAVE;
4006     }
4007   }
4008
4009 =head1 DESCRIPTION
4010
4011 Imager is a module for creating and altering images.  It can read and
4012 write various image formats, draw primitive shapes like lines,and
4013 polygons, blend multiple images together in various ways, scale, crop,
4014 render text and more.
4015
4016 =head2 Overview of documentation
4017
4018 =over
4019
4020 =item *
4021
4022 Imager - This document - Synopsis, Example, Table of Contents and
4023 Overview.
4024
4025 =item *
4026
4027 L<Imager::Tutorial> - a brief introduction to Imager.
4028
4029 =item *
4030
4031 L<Imager::Cookbook> - how to do various things with Imager.
4032
4033 =item *
4034
4035 L<Imager::ImageTypes> - Basics of constructing image objects with
4036 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4037 8/16/double bits/channel, color maps, channel masks, image tags, color
4038 quantization.  Also discusses basic image information methods.
4039
4040 =item *
4041
4042 L<Imager::Files> - IO interaction, reading/writing images, format
4043 specific tags.
4044
4045 =item *
4046
4047 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4048 flood fill.
4049
4050 =item *
4051
4052 L<Imager::Color> - Color specification.
4053
4054 =item *
4055
4056 L<Imager::Fill> - Fill pattern specification.
4057
4058 =item *
4059
4060 L<Imager::Font> - General font rendering, bounding boxes and font
4061 metrics.
4062
4063 =item *
4064
4065 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4066 blending, pasting, convert and map.
4067
4068 =item *
4069
4070 L<Imager::Engines> - Programmable transformations through
4071 C<transform()>, C<transform2()> and C<matrix_transform()>.
4072
4073 =item *
4074
4075 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4076 filter plug-ins.
4077
4078 =item *
4079
4080 L<Imager::Expr> - Expressions for evaluation engine used by
4081 transform2().
4082
4083 =item *
4084
4085 L<Imager::Matrix2d> - Helper class for affine transformations.
4086
4087 =item *
4088
4089 L<Imager::Fountain> - Helper for making gradient profiles.
4090
4091 =item *
4092
4093 L<Imager::API> - using Imager's C API
4094
4095 =item *
4096
4097 L<Imager::APIRef> - API function reference
4098
4099 =item *
4100
4101 L<Imager::Inline> - using Imager's C API from Inline::C
4102
4103 =item *
4104
4105 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4106
4107 =back
4108
4109 =head2 Basic Overview
4110
4111 An Image object is created with C<$img = Imager-E<gt>new()>.
4112 Examples:
4113
4114   $img=Imager->new();                         # create empty image
4115   $img->read(file=>'lena.png',type=>'png') or # read image from file
4116      die $img->errstr();                      # give an explanation
4117                                               # if something failed
4118
4119 or if you want to create an empty image:
4120
4121   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4122
4123 This example creates a completely black image of width 400 and height
4124 300 and 4 channels.
4125
4126 =head1 ERROR HANDLING
4127
4128 In general a method will return false when it fails, if it does use
4129 the C<errstr()> method to find out why:
4130
4131 =over
4132
4133 =item C<errstr>
4134
4135 Returns the last error message in that context.
4136
4137 If the last error you received was from calling an object method, such
4138 as read, call errstr() as an object method to find out why:
4139
4140   my $image = Imager->new;
4141   $image->read(file => 'somefile.gif')
4142      or die $image->errstr;
4143
4144 If it was a class method then call errstr() as a class method:
4145
4146   my @imgs = Imager->read_multi(file => 'somefile.gif')
4147     or die Imager->errstr;
4148
4149 Note that in some cases object methods are implemented in terms of
4150 class methods so a failing object method may set both.
4151
4152 =back
4153
4154 The C<Imager-E<gt>new> method is described in detail in
4155 L<Imager::ImageTypes>.
4156
4157 =head1 METHOD INDEX
4158
4159 Where to find information on methods for Imager class objects.
4160
4161 addcolors() - L<Imager::ImageTypes/addcolors> - add colors to a
4162 paletted image
4163
4164 addtag() -  L<Imager::ImageTypes/addtag> - add image tags
4165
4166 align_string() - L<Imager::Draw/align_string> - draw text aligned on a
4167 point
4168
4169 arc() - L<Imager::Draw/arc> - draw a filled arc
4170
4171 bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
4172 image
4173
4174 box() - L<Imager::Draw/box> - draw a filled or outline box.
4175
4176 circle() - L<Imager::Draw/circle> - draw a filled circle
4177
4178 colorcount() - L<Imager::Draw/colorcount> - the number of colors in an
4179 image's palette (paletted images only)
4180
4181 combines() - L<Imager::Draw/combines> - return a list of the different
4182 combine type keywords
4183
4184 compose() - L<Imager::Transformations/compose> - compose one image
4185 over another.
4186
4187 convert() - L<Imager::Transformations/"Color transformations"> -
4188 transform the color space
4189
4190 copy() - L<Imager::Transformations/copy> - make a duplicate of an
4191 image
4192
4193 crop() - L<Imager::Transformations/crop> - extract part of an image
4194
4195 def_guess_type() - L<Imager::Files/def_guess_type> - default function
4196 used to guess the output file format based on the output file name
4197
4198 deltag() -  L<Imager::ImageTypes/deltag> - delete image tags
4199
4200 difference() - L<Imager::Filters/"Image Difference"> - produce a
4201 difference images from two input images.
4202
4203 errstr() - L<"Basic Overview"> - the error from the last failed
4204 operation.
4205
4206 filter() - L<Imager::Filters> - image filtering
4207
4208 findcolor() - L<Imager::ImageTypes/findcolor> - search the image
4209 palette, if it has one
4210
4211 flip() - L<Imager::Transformations/flip> - flip an image, vertically,
4212 horizontally
4213
4214 flood_fill() - L<Imager::Draw/flood_fill> - fill an enclosed or same
4215 color area
4216
4217 getchannels() - L<Imager::ImageTypes/getchannels> - the number of
4218 samples per pixel for an image
4219
4220 getcolorcount() - L<Imager::ImageTypes/getcolorcount> - the number of
4221 different colors used by an image (works for direct color images)
4222
4223 getcolors() - L<Imager::ImageTypes/getcolors> - get colors from the image
4224 palette, if it has one
4225
4226 getcolorusage() - L<Imager::ImageTypes/getcolorusage>
4227
4228 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash>
4229
4230 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
4231
4232 getheight() - L<Imager::ImageTypes/getwidth> - height of the image in
4233 pixels
4234
4235 getmask() - L<Imager::ImageTypes/getmask> - write mask for the image
4236
4237 getpixel() - L<Imager::Draw/getpixel> - retrieve one or more pixel
4238 colors
4239
4240 getsamples() - L<Imager::Draw/getsamples> - retrieve samples from a
4241 row or partial row of pixels.
4242
4243 getscanline() - L<Imager::Draw/getscanline> - retrieve colors for a
4244 row or partial row of pixels.
4245
4246 getwidth() - L<Imager::ImageTypes/getwidth> - width of the image in
4247 pixels.
4248
4249 img_set() - L<Imager::ImageTypes/img_set> - re-use an Imager object
4250 for a new image.
4251
4252 init() - L<Imager::ImageTypes/init>
4253
4254 is_bilevel() - L<Imager::ImageTypes/is_bilevel> - returns whether
4255 image write functions should write the image in their bilevel (blank
4256 and white, no gray levels) format
4257
4258 line() - L<Imager::Draw/line> - draw an interval
4259
4260 load_plugin() - L<Imager::Filters/load_plugin>
4261
4262 map() - L<Imager::Transformations/"Color Mappings"> - remap color
4263 channel values
4264
4265 masked() -  L<Imager::ImageTypes/masked> - make a masked image
4266
4267 matrix_transform() - L<Imager::Engines/matrix_transform>
4268
4269 maxcolors() - L<Imager::ImageTypes/maxcolors>
4270
4271 NC() - L<Imager::Handy/NC>
4272
4273 NCF() - L<Imager::Handy/NCF>
4274
4275 new() - L<Imager::ImageTypes/new>
4276
4277 newcolor() - L<Imager::Handy/newcolor>
4278
4279 newcolour() - L<Imager::Handy/newcolour>
4280
4281 newfont() - L<Imager::Handy/newfont>
4282
4283 NF() - L<Imager::Handy/NF>
4284
4285 open() - L<Imager::Files> - an alias for read()
4286
4287 =for stopwords IPTC
4288
4289 parseiptc() - L<Imager::Files/parseiptc> - parse IPTC data from a JPEG
4290 image
4291
4292 paste() - L<Imager::Transformations/paste> - draw an image onto an image
4293
4294 polygon() - L<Imager::Draw/polygon>
4295
4296 polyline() - L<Imager::Draw/polyline>
4297
4298 read() - L<Imager::Files> - read a single image from an image file
4299
4300 read_multi() - L<Imager::Files> - read multiple images from an image
4301 file
4302
4303 read_types() - L<Imager::Files/read_types> - list image types Imager
4304 can read.
4305
4306 register_filter() - L<Imager::Filters/register_filter>
4307
4308 register_reader() - L<Imager::Files/register_reader>
4309
4310 register_writer() - L<Imager::Files/register_writer>
4311
4312 rotate() - L<Imager::Transformations/rotate>
4313
4314 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
4315 image and use the alpha channel
4316
4317 scale() - L<Imager::Transformations/scale>
4318
4319 scale_calculate() - L<Imager::Transformations/scale_calculate>
4320
4321 scaleX() - L<Imager::Transformations/scaleX>
4322
4323 scaleY() - L<Imager::Transformations/scaleY>
4324
4325 setcolors() - L<Imager::ImageTypes/setcolors> - set palette colors in
4326 a paletted image
4327
4328 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
4329
4330 setmask() - L<Imager::ImageTypes/setmask>
4331
4332 setpixel() - L<Imager::Draw/setpixel>
4333
4334 setsamples() - L<Imager::Draw/setsamples>
4335
4336 setscanline() - L<Imager::Draw/setscanline>
4337
4338 settag() - L<Imager::ImageTypes/settag>
4339
4340 string() - L<Imager::Draw/string> - draw text on an image
4341
4342 tags() -  L<Imager::ImageTypes/tags> - fetch image tags
4343
4344 to_paletted() -  L<Imager::ImageTypes/to_paletted>
4345
4346 to_rgb16() - L<Imager::ImageTypes/to_rgb16>
4347
4348 to_rgb8() - L<Imager::ImageTypes/to_rgb8>
4349
4350 transform() - L<Imager::Engines/"transform">
4351
4352 transform2() - L<Imager::Engines/"transform2">
4353
4354 type() -  L<Imager::ImageTypes/type> - type of image (direct vs paletted)
4355
4356 unload_plugin() - L<Imager::Filters/unload_plugin>
4357
4358 virtual() - L<Imager::ImageTypes/virtual> - whether the image has it's own
4359 data
4360
4361 write() - L<Imager::Files> - write an image to a file
4362
4363 write_multi() - L<Imager::Files> - write multiple image to an image
4364 file.
4365
4366 write_types() - L<Imager::Files/read_types> - list image types Imager
4367 can write.
4368
4369 =head1 CONCEPT INDEX
4370
4371 animated GIF - L<Imager::Files/"Writing an animated GIF">
4372
4373 aspect ratio - L<Imager::ImageTypes/i_xres>,
4374 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
4375
4376 blend - alpha blending one image onto another
4377 L<Imager::Transformations/rubthrough>
4378
4379 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
4380
4381 boxes, drawing - L<Imager::Draw/box>
4382
4383 changes between image - L<Imager::Filters/"Image Difference">
4384
4385 color - L<Imager::Color>
4386
4387 color names - L<Imager::Color>, L<Imager::Color::Table>
4388
4389 combine modes - L<Imager::Draw/"Combine Types">
4390
4391 compare images - L<Imager::Filters/"Image Difference">
4392
4393 contrast - L<Imager::Filters/contrast>, L<Imager::Filters/autolevels>
4394
4395 convolution - L<Imager::Filters/conv>
4396
4397 cropping - L<Imager::Transformations/crop>
4398
4399 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4400
4401 C<diff> images - L<Imager::Filters/"Image Difference">
4402
4403 dpi - L<Imager::ImageTypes/i_xres>,
4404 L<Imager::Cookbook/"Image spatial resolution">
4405
4406 drawing boxes - L<Imager::Draw/box>
4407
4408 drawing lines - L<Imager::Draw/line>
4409
4410 drawing text - L<Imager::Draw/string>, L<Imager::Draw/align_string>
4411
4412 error message - L<"ERROR HANDLING">
4413
4414 files, font - L<Imager::Font>
4415
4416 files, image - L<Imager::Files>
4417
4418 filling, types of fill - L<Imager::Fill>
4419
4420 filling, boxes - L<Imager::Draw/box>
4421
4422 filling, flood fill - L<Imager::Draw/flood_fill>
4423
4424 flood fill - L<Imager::Draw/flood_fill>
4425
4426 fonts - L<Imager::Font>
4427
4428 fonts, drawing with - L<Imager::Draw/string>,
4429 L<Imager::Draw/align_string>, L<Imager::Font::Wrap>
4430
4431 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4432
4433 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4434
4435 fountain fill - L<Imager::Fill/"Fountain fills">,
4436 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4437 L<Imager::Filters/gradgen>
4438
4439 GIF files - L<Imager::Files/"GIF">
4440
4441 GIF files, animated - L<Imager::File/"Writing an animated GIF">
4442
4443 gradient fill - L<Imager::Fill/"Fountain fills">,
4444 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4445 L<Imager::Filters/gradgen>
4446
4447 gray scale, convert image to - L<Imager::Transformations/convert>
4448
4449 guassian blur - L<Imager::Filters/guassian>
4450
4451 hatch fills - L<Imager::Fill/"Hatched fills">
4452
4453 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4454
4455 invert image - L<Imager::Filters/hardinvert>,
4456 L<Imager::Filters/hardinvertall>
4457
4458 JPEG - L<Imager::Files/"JPEG">
4459
4460 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4461
4462 lines, drawing - L<Imager::Draw/line>
4463
4464 matrix - L<Imager::Matrix2d>,
4465 L<Imager::Transformations/"Matrix Transformations">,
4466 L<Imager::Font/transform>
4467
4468 metadata, image - L<Imager::ImageTypes/"Tags">
4469
4470 mosaic - L<Imager::Filters/mosaic>
4471
4472 noise, filter - L<Imager::Filters/noise>
4473
4474 noise, rendered - L<Imager::Filters/turbnoise>,
4475 L<Imager::Filters/radnoise>
4476
4477 paste - L<Imager::Transformations/paste>,
4478 L<Imager::Transformations/rubthrough>
4479
4480 pseudo-color image - L<Imager::ImageTypes/to_paletted>,
4481 L<Imager::ImageTypes/new>
4482
4483 =for stopwords posterize
4484
4485 posterize - L<Imager::Filters/postlevels>
4486
4487 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
4488
4489 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
4490
4491 rectangles, drawing - L<Imager::Draw/box>
4492
4493 resizing an image - L<Imager::Transformations/scale>,
4494 L<Imager::Transformations/crop>
4495
4496 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4497
4498 saving an image - L<Imager::Files>
4499
4500 scaling - L<Imager::Transformations/scale>
4501
4502 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4503
4504 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4505
4506 size, image - L<Imager::ImageTypes/getwidth>,
4507 L<Imager::ImageTypes/getheight>
4508
4509 size, text - L<Imager::Font/bounding_box>
4510
4511 tags, image metadata - L<Imager::ImageTypes/"Tags">
4512
4513 text, drawing - L<Imager::Draw/string>, L<Imager::Draw/align_string>,
4514 L<Imager::Font::Wrap>
4515
4516 text, wrapping text in an area - L<Imager::Font::Wrap>
4517
4518 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4519
4520 tiles, color - L<Imager::Filters/mosaic>
4521
4522 =for stopwords unsharp
4523
4524 unsharp mask - L<Imager::Filters/unsharpmask>
4525
4526 watermark - L<Imager::Filters/watermark>
4527
4528 writing an image to a file - L<Imager::Files>
4529
4530 =head1 THREADS
4531
4532 Imager doesn't support perl threads.
4533
4534 Imager has limited code to prevent double frees if you create images,
4535 colors etc, and then create a thread, but has no code to prevent two
4536 threads entering Imager's error handling code, and none is likely to
4537 be added.
4538
4539 =head1 SUPPORT
4540
4541 The best place to get help with Imager is the mailing list.
4542
4543 To subscribe send a message with C<subscribe> in the body to:
4544
4545    imager-devel+request@molar.is
4546
4547 or use the form at:
4548
4549 =over
4550
4551 L<http://www.molar.is/en/lists/imager-devel/>
4552
4553 =back
4554
4555 where you can also find the mailing list archive.
4556
4557 You can report bugs by pointing your browser at:
4558
4559 =over
4560
4561 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4562
4563 =back
4564
4565 or by sending an email to:
4566
4567 =over
4568
4569 bug-Imager@rt.cpan.org
4570
4571 =back
4572
4573 Please remember to include the versions of Imager, perl, supporting
4574 libraries, and any relevant code.  If you have specific images that
4575 cause the problems, please include those too.
4576
4577 If you don't want to publish your email address on a mailing list you
4578 can use CPAN::Forum:
4579
4580   http://www.cpanforum.com/dist/Imager
4581
4582 You will need to register to post.
4583
4584 =head1 CONTRIBUTING TO IMAGER
4585
4586 =head2 Feedback
4587
4588 I like feedback.
4589
4590 If you like or dislike Imager, you can add a public review of Imager
4591 at CPAN Ratings:
4592
4593   http://cpanratings.perl.org/dist/Imager
4594
4595 =for stopwords Bitcard
4596
4597 This requires a Bitcard account (http://www.bitcard.org).
4598
4599 You can also send email to the maintainer below.
4600
4601 If you send me a bug report via email, it will be copied to Request
4602 Tracker.
4603
4604 =head2 Patches
4605
4606 I accept patches, preferably against the main branch in subversion.
4607 You should include an explanation of the reason for why the patch is
4608 needed or useful.
4609
4610 Your patch should include regression tests where possible, otherwise
4611 it will be delayed until I get a chance to write them.
4612
4613 =head1 AUTHOR
4614
4615 Tony Cook <tony@imager.perl.org> is the current maintainer for Imager.
4616
4617 Arnar M. Hrafnkelsson is the original author of Imager.
4618
4619 Many others have contributed to Imager, please see the C<README> for a
4620 complete list.
4621
4622 =head1 SEE ALSO
4623
4624 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4625 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4626 L<Imager::Font>(3), L<Imager::Transformations>(3),
4627 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4628 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4629
4630 L<http://imager.perl.org/>
4631
4632 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4633
4634 Other perl imaging modules include:
4635
4636 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3).
4637
4638 =cut