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