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