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 # options that should be converted to colors
1597 my %color_opts = map { $_ => 1 } qw/i_background/;
1598
1599 sub _set_opts {
1600   my ($self, $opts, $prefix, @imgs) = @_;
1601
1602   for my $opt (keys %$opts) {
1603     my $tagname = $opt;
1604     if ($obsolete_opts{$opt}) {
1605       my $new = $obsolete_opts{$opt};
1606       my $msg = "Obsolete option $opt ";
1607       if (ref $new) {
1608         $new->($opts, $opt, \$msg, @imgs);
1609       }
1610       else {
1611         $msg .= "replaced with the $new tag ";
1612         $tagname = $new;
1613       }
1614       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1615       warn $msg if $warn_obsolete && $^W;
1616     }
1617     next unless $tagname =~ /^\Q$prefix/;
1618     my $value = $opts->{$opt};
1619     if ($color_opts{$opt}) {
1620       $value = _color($value);
1621       unless ($value) {
1622         $self->_set_error($Imager::ERRSTR);
1623         return;
1624       }
1625     }
1626     if (ref $value) {
1627       if (UNIVERSAL::isa($value, "Imager::Color")) {
1628         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1629         for my $img (@imgs) {
1630           $img->settag(name=>$tagname, value=>$tag);
1631         }
1632       }
1633       elsif (ref($value) eq 'ARRAY') {
1634         for my $i (0..$#$value) {
1635           my $val = $value->[$i];
1636           if (ref $val) {
1637             if (UNIVERSAL::isa($val, "Imager::Color")) {
1638               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1639               $i < @imgs and
1640                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1641             }
1642             else {
1643               $self->_set_error("Unknown reference type " . ref($value) .
1644                                 " supplied in array for $opt");
1645               return;
1646             }
1647           }
1648           else {
1649             $i < @imgs
1650               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1651           }
1652         }
1653       }
1654       else {
1655         $self->_set_error("Unknown reference type " . ref($value) .
1656                           " supplied for $opt");
1657         return;
1658       }
1659     }
1660     else {
1661       # set it as a tag for every image
1662       for my $img (@imgs) {
1663         $img->settag(name=>$tagname, value=>$value);
1664       }
1665     }
1666   }
1667
1668   return 1;
1669 }
1670
1671 # Write an image to file
1672 sub write {
1673   my $self = shift;
1674   my %input=(jpegquality=>75,
1675              gifquant=>'mc',
1676              lmdither=>6.0,
1677              lmfixed=>[],
1678              idstring=>"",
1679              compress=>1,
1680              wierdpack=>0,
1681              fax_fine=>1, @_);
1682   my $rc;
1683
1684   $self->_set_opts(\%input, "i_", $self)
1685     or return undef;
1686
1687   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1688
1689   if (!$input{'type'} and $input{file}) {
1690     $input{'type'}=$FORMATGUESS->($input{file});
1691   }
1692   if (!$input{'type'}) {
1693     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1694     return undef;
1695   }
1696
1697   _writer_autoload($input{type});
1698
1699   my ($IO, $fh);
1700   if ($writers{$input{type}} && $writers{$input{type}}{single}) {
1701     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1702       or return undef;
1703
1704     $writers{$input{type}}{single}->($self, $IO, %input)
1705       or return undef;
1706   }
1707   else {
1708     if (!$formats{$input{'type'}}) {
1709       my $write_types = join ', ', sort Imager->write_types();
1710       $self->_set_error("format '$input{'type'}' not supported - formats $write_types available for writing");
1711       return undef;
1712     }
1713
1714     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1715       or return undef;
1716
1717     if ($input{'type'} eq 'tiff') {
1718       $self->_set_opts(\%input, "tiff_", $self)
1719         or return undef;
1720       $self->_set_opts(\%input, "exif_", $self)
1721         or return undef;
1722
1723       if (defined $input{class} && $input{class} eq 'fax') {
1724         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1725           $self->{ERRSTR} = $self->_error_as_msg();
1726           return undef;
1727         }
1728       } else {
1729         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1730           $self->{ERRSTR} = $self->_error_as_msg();
1731           return undef;
1732         }
1733       }
1734     } elsif ( $input{'type'} eq 'pnm' ) {
1735       $self->_set_opts(\%input, "pnm_", $self)
1736         or return undef;
1737       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1738         $self->{ERRSTR} = $self->_error_as_msg();
1739         return undef;
1740       }
1741       $self->{DEBUG} && print "writing a pnm file\n";
1742     } elsif ( $input{'type'} eq 'raw' ) {
1743       $self->_set_opts(\%input, "raw_", $self)
1744         or return undef;
1745       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1746         $self->{ERRSTR} = $self->_error_as_msg();
1747         return undef;
1748       }
1749       $self->{DEBUG} && print "writing a raw file\n";
1750     } elsif ( $input{'type'} eq 'png' ) {
1751       $self->_set_opts(\%input, "png_", $self)
1752         or return undef;
1753       if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1754         $self->{ERRSTR}='unable to write png image';
1755         return undef;
1756       }
1757       $self->{DEBUG} && print "writing a png file\n";
1758     } elsif ( $input{'type'} eq 'jpeg' ) {
1759       $self->_set_opts(\%input, "jpeg_", $self)
1760         or return undef;
1761       $self->_set_opts(\%input, "exif_", $self)
1762         or return undef;
1763       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1764         $self->{ERRSTR} = $self->_error_as_msg();
1765         return undef;
1766       }
1767       $self->{DEBUG} && print "writing a jpeg file\n";
1768     } elsif ( $input{'type'} eq 'bmp' ) {
1769       $self->_set_opts(\%input, "bmp_", $self)
1770         or return undef;
1771       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1772         $self->{ERRSTR} = $self->_error_as_msg;
1773         return undef;
1774       }
1775       $self->{DEBUG} && print "writing a bmp file\n";
1776     } elsif ( $input{'type'} eq 'tga' ) {
1777       $self->_set_opts(\%input, "tga_", $self)
1778         or return undef;
1779
1780       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1781         $self->{ERRSTR}=$self->_error_as_msg();
1782         return undef;
1783       }
1784       $self->{DEBUG} && print "writing a tga file\n";
1785     } elsif ( $input{'type'} eq 'gif' ) {
1786       $self->_set_opts(\%input, "gif_", $self)
1787         or return undef;
1788       # compatibility with the old interfaces
1789       if ($input{gifquant} eq 'lm') {
1790         $input{make_colors} = 'addi';
1791         $input{translate} = 'perturb';
1792         $input{perturb} = $input{lmdither};
1793       } elsif ($input{gifquant} eq 'gen') {
1794         # just pass options through
1795       } else {
1796         $input{make_colors} = 'webmap'; # ignored
1797         $input{translate} = 'giflib';
1798       }
1799       if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1800         $self->{ERRSTR} = $self->_error_as_msg;
1801         return;
1802       }
1803     }
1804   }
1805
1806   if (exists $input{'data'}) {
1807     my $data = io_slurp($IO);
1808     if (!$data) {
1809       $self->{ERRSTR}='Could not slurp from buffer';
1810       return undef;
1811     }
1812     ${$input{data}} = $data;
1813   }
1814   return $self;
1815 }
1816
1817 sub write_multi {
1818   my ($class, $opts, @images) = @_;
1819
1820   my $type = $opts->{type};
1821
1822   if (!$type && $opts->{'file'}) {
1823     $type = $FORMATGUESS->($opts->{'file'});
1824   }
1825   unless ($type) {
1826     $class->_set_error('type parameter missing and not possible to guess from extension');
1827     return;
1828   }
1829   # translate to ImgRaw
1830   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1831     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1832     return 0;
1833   }
1834   $class->_set_opts($opts, "i_", @images)
1835     or return;
1836   my @work = map $_->{IMG}, @images;
1837
1838   _writer_autoload($type);
1839
1840   my ($IO, $file);
1841   if ($writers{$type} && $writers{$type}{multiple}) {
1842     ($IO, $file) = $class->_get_writer_io($opts, $type)
1843       or return undef;
1844
1845     $writers{$type}{multiple}->($class, $IO, $opts, @images)
1846       or return undef;
1847   }
1848   else {
1849     if (!$formats{$type}) {
1850       my $write_types = join ', ', sort Imager->write_types();
1851       $class->_set_error("format '$type' not supported - formats $write_types available for writing");
1852       return undef;
1853     }
1854
1855     ($IO, $file) = $class->_get_writer_io($opts, $type)
1856       or return undef;
1857
1858     if ($type eq 'gif') {
1859       $class->_set_opts($opts, "gif_", @images)
1860         or return;
1861       my $gif_delays = $opts->{gif_delays};
1862       local $opts->{gif_delays} = $gif_delays;
1863       if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1864         # assume the caller wants the same delay for each frame
1865         $opts->{gif_delays} = [ ($gif_delays) x @images ];
1866       }
1867       unless (i_writegif_wiol($IO, $opts, @work)) {
1868         $class->_set_error($class->_error_as_msg());
1869         return undef;
1870       }
1871     }
1872     elsif ($type eq 'tiff') {
1873       $class->_set_opts($opts, "tiff_", @images)
1874         or return;
1875       $class->_set_opts($opts, "exif_", @images)
1876         or return;
1877       my $res;
1878       $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1879       if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1880         $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1881       }
1882       else {
1883         $res = i_writetiff_multi_wiol($IO, @work);
1884       }
1885       unless ($res) {
1886         $class->_set_error($class->_error_as_msg());
1887         return undef;
1888       }
1889     }
1890     else {
1891       if (@images == 1) {
1892         unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1893           return 1;
1894         }
1895       }
1896       else {
1897         $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1898         return 0;
1899       }
1900     }
1901   }
1902
1903   if (exists $opts->{'data'}) {
1904     my $data = io_slurp($IO);
1905     if (!$data) {
1906       Imager->_set_error('Could not slurp from buffer');
1907       return undef;
1908     }
1909     ${$opts->{data}} = $data;
1910   }
1911   return 1;
1912 }
1913
1914 # read multiple images from a file
1915 sub read_multi {
1916   my ($class, %opts) = @_;
1917
1918   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1919     or return;
1920
1921   my $type = $opts{'type'};
1922   unless ($type) {
1923     $type = i_test_format_probe($IO, -1);
1924   }
1925
1926   if ($opts{file} && !$type) {
1927     # guess the type
1928     $type = $FORMATGUESS->($opts{file});
1929   }
1930
1931   unless ($type) {
1932     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1933     return;
1934   }
1935
1936   _reader_autoload($type);
1937
1938   if ($readers{$type} && $readers{$type}{multiple}) {
1939     return $readers{$type}{multiple}->($IO, %opts);
1940   }
1941
1942   if ($type eq 'gif') {
1943     my @imgs;
1944     @imgs = i_readgif_multi_wiol($IO);
1945     if (@imgs) {
1946       return map {
1947         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1948       } @imgs;
1949     }
1950     else {
1951       $ERRSTR = _error_as_msg();
1952       return;
1953     }
1954   }
1955   elsif ($type eq 'tiff') {
1956     my @imgs = i_readtiff_multi_wiol($IO, -1);
1957     if (@imgs) {
1958       return map {
1959         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1960       } @imgs;
1961     }
1962     else {
1963       $ERRSTR = _error_as_msg();
1964       return;
1965     }
1966   }
1967   else {
1968     my $img = Imager->new;
1969     if ($img->read(%opts, io => $IO, type => $type)) {
1970       return ( $img );
1971     }
1972     Imager->_set_error($img->errstr);
1973   }
1974
1975   return;
1976 }
1977
1978 # Destroy an Imager object
1979
1980 sub DESTROY {
1981   my $self=shift;
1982   #    delete $instances{$self};
1983   if (defined($self->{IMG})) {
1984     # the following is now handled by the XS DESTROY method for
1985     # Imager::ImgRaw object
1986     # Re-enabling this will break virtual images
1987     # tested for in t/t020masked.t
1988     # i_img_destroy($self->{IMG});
1989     undef($self->{IMG});
1990   } else {
1991 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1992   }
1993 }
1994
1995 # Perform an inplace filter of an image
1996 # that is the image will be overwritten with the data
1997
1998 sub filter {
1999   my $self=shift;
2000   my %input=@_;
2001   my %hsh;
2002   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2003
2004   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
2005
2006   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
2007     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2008   }
2009
2010   if ($filters{$input{'type'}}{names}) {
2011     my $names = $filters{$input{'type'}}{names};
2012     for my $name (keys %$names) {
2013       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2014         $input{$name} = $names->{$name}{$input{$name}};
2015       }
2016     }
2017   }
2018   if (defined($filters{$input{'type'}}{defaults})) {
2019     %hsh=( image => $self->{IMG},
2020            imager => $self,
2021            %{$filters{$input{'type'}}{defaults}},
2022            %input );
2023   } else {
2024     %hsh=( image => $self->{IMG},
2025            imager => $self,
2026            %input );
2027   }
2028
2029   my @cs=@{$filters{$input{'type'}}{callseq}};
2030
2031   for(@cs) {
2032     if (!defined($hsh{$_})) {
2033       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
2034     }
2035   }
2036
2037   eval {
2038     local $SIG{__DIE__}; # we don't want this processed by confess, etc
2039     &{$filters{$input{'type'}}{callsub}}(%hsh);
2040   };
2041   if ($@) {
2042     chomp($self->{ERRSTR} = $@);
2043     return;
2044   }
2045
2046   my @b=keys %hsh;
2047
2048   $self->{DEBUG} && print "callseq is: @cs\n";
2049   $self->{DEBUG} && print "matching callseq is: @b\n";
2050
2051   return $self;
2052 }
2053
2054 sub register_filter {
2055   my $class = shift;
2056   my %hsh = ( defaults => {}, @_ );
2057
2058   defined $hsh{type}
2059     or die "register_filter() with no type\n";
2060   defined $hsh{callsub}
2061     or die "register_filter() with no callsub\n";
2062   defined $hsh{callseq}
2063     or die "register_filter() with no callseq\n";
2064
2065   exists $filters{$hsh{type}}
2066     and return;
2067
2068   $filters{$hsh{type}} = \%hsh;
2069
2070   return 1;
2071 }
2072
2073 sub scale_calculate {
2074   my $self = shift;
2075
2076   my %opts = ('type'=>'max', @_);
2077
2078   my ($x_scale, $y_scale);
2079   my $width = $opts{width};
2080   my $height = $opts{height};
2081   if (ref $self) {
2082     defined $width or $width = $self->getwidth;
2083     defined $height or $height = $self->getheight;
2084   }
2085   else {
2086     unless (defined $width && defined $height) {
2087       $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2088       return;
2089     }
2090   }
2091
2092   if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2093     $x_scale = $opts{'xscalefactor'};
2094     $y_scale = $opts{'yscalefactor'};
2095   }
2096   elsif ($opts{'xscalefactor'}) {
2097     $x_scale = $opts{'xscalefactor'};
2098     $y_scale = $opts{'scalefactor'} || $x_scale;
2099   }
2100   elsif ($opts{'yscalefactor'}) {
2101     $y_scale = $opts{'yscalefactor'};
2102     $x_scale = $opts{'scalefactor'} || $y_scale;
2103   }
2104   else {
2105     $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2106   }
2107
2108   # work out the scaling
2109   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
2110     my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2111                         $opts{ypixels} / $height );
2112     if ($opts{'type'} eq 'min') {
2113       $x_scale = $y_scale = _min($xpix,$ypix);
2114     }
2115     elsif ($opts{'type'} eq 'max') {
2116       $x_scale = $y_scale = _max($xpix,$ypix);
2117     }
2118     elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2119       $x_scale = $xpix;
2120       $y_scale = $ypix;
2121     }
2122     else {
2123       $self->_set_error('invalid value for type parameter');
2124       return;
2125     }
2126   } elsif ($opts{xpixels}) {
2127     $x_scale = $y_scale = $opts{xpixels} / $width;
2128   }
2129   elsif ($opts{ypixels}) {
2130     $x_scale = $y_scale = $opts{ypixels}/$height;
2131   }
2132   elsif ($opts{constrain} && ref $opts{constrain}
2133          && $opts{constrain}->can('constrain')) {
2134     # we've been passed an Image::Math::Constrain object or something
2135     # that looks like one
2136     my $scalefactor;
2137     (undef, undef, $scalefactor)
2138       = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2139     unless ($scalefactor) {
2140       $self->_set_error('constrain method failed on constrain parameter');
2141       return;
2142     }
2143     $x_scale = $y_scale = $scalefactor;
2144   }
2145
2146   my $new_width = int($x_scale * $width + 0.5);
2147   $new_width > 0 or $new_width = 1;
2148   my $new_height = int($y_scale * $height + 0.5);
2149   $new_height > 0 or $new_height = 1;
2150
2151   return ($x_scale, $y_scale, $new_width, $new_height);
2152
2153 }
2154
2155 # Scale an image to requested size and return the scaled version
2156
2157 sub scale {
2158   my $self=shift;
2159   my %opts = (qtype=>'normal' ,@_);
2160   my $img = Imager->new();
2161   my $tmp = Imager->new();
2162
2163   unless (defined wantarray) {
2164     my @caller = caller;
2165     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2166     return;
2167   }
2168
2169   unless ($self->{IMG}) {
2170     $self->_set_error('empty input image');
2171     return undef;
2172   }
2173
2174   my ($x_scale, $y_scale, $new_width, $new_height) =
2175     $self->scale_calculate(%opts)
2176       or return;
2177
2178   if ($opts{qtype} eq 'normal') {
2179     $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2180     if ( !defined($tmp->{IMG}) ) {
2181       $self->{ERRSTR} = 'unable to scale image';
2182       return undef;
2183     }
2184     $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2185     if ( !defined($img->{IMG}) ) {
2186       $self->{ERRSTR}='unable to scale image';
2187       return undef;
2188     }
2189
2190     return $img;
2191   }
2192   elsif ($opts{'qtype'} eq 'preview') {
2193     $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
2194     if ( !defined($img->{IMG}) ) {
2195       $self->{ERRSTR}='unable to scale image';
2196       return undef;
2197     }
2198     return $img;
2199   }
2200   elsif ($opts{'qtype'} eq 'mixing') {
2201     $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2202     unless ($img->{IMG}) {
2203       $self->_set_error(Imager->_error_as_meg);
2204       return;
2205     }
2206     return $img;
2207   }
2208   else {
2209     $self->_set_error('invalid value for qtype parameter');
2210     return undef;
2211   }
2212 }
2213
2214 # Scales only along the X axis
2215
2216 sub scaleX {
2217   my $self = shift;
2218   my %opts = ( scalefactor=>0.5, @_ );
2219
2220   unless (defined wantarray) {
2221     my @caller = caller;
2222     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2223     return;
2224   }
2225
2226   unless ($self->{IMG}) {
2227     $self->{ERRSTR} = 'empty input image';
2228     return undef;
2229   }
2230
2231   my $img = Imager->new();
2232
2233   my $scalefactor = $opts{scalefactor};
2234
2235   if ($opts{pixels}) {
2236     $scalefactor = $opts{pixels} / $self->getwidth();
2237   }
2238
2239   unless ($self->{IMG}) {
2240     $self->{ERRSTR}='empty input image';
2241     return undef;
2242   }
2243
2244   $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2245
2246   if ( !defined($img->{IMG}) ) {
2247     $self->{ERRSTR} = 'unable to scale image';
2248     return undef;
2249   }
2250
2251   return $img;
2252 }
2253
2254 # Scales only along the Y axis
2255
2256 sub scaleY {
2257   my $self = shift;
2258   my %opts = ( scalefactor => 0.5, @_ );
2259
2260   unless (defined wantarray) {
2261     my @caller = caller;
2262     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2263     return;
2264   }
2265
2266   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2267
2268   my $img = Imager->new();
2269
2270   my $scalefactor = $opts{scalefactor};
2271
2272   if ($opts{pixels}) {
2273     $scalefactor = $opts{pixels} / $self->getheight();
2274   }
2275
2276   unless ($self->{IMG}) {
2277     $self->{ERRSTR} = 'empty input image';
2278     return undef;
2279   }
2280   $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2281
2282   if ( !defined($img->{IMG}) ) {
2283     $self->{ERRSTR} = 'unable to scale image';
2284     return undef;
2285   }
2286
2287   return $img;
2288 }
2289
2290 # Transform returns a spatial transformation of the input image
2291 # this moves pixels to a new location in the returned image.
2292 # NOTE - should make a utility function to check transforms for
2293 # stack overruns
2294
2295 sub transform {
2296   my $self=shift;
2297   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2298   my %opts=@_;
2299   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2300
2301 #  print Dumper(\%opts);
2302 #  xopcopdes
2303
2304   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2305     if (!$I2P) {
2306       eval ("use Affix::Infix2Postfix;");
2307       print $@;
2308       if ( $@ ) {
2309         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2310         return undef;
2311       }
2312       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2313                                              {op=>'-',trans=>'Sub'},
2314                                              {op=>'*',trans=>'Mult'},
2315                                              {op=>'/',trans=>'Div'},
2316                                              {op=>'-','type'=>'unary',trans=>'u-'},
2317                                              {op=>'**'},
2318                                              {op=>'func','type'=>'unary'}],
2319                                      'grouping'=>[qw( \( \) )],
2320                                      'func'=>[qw( sin cos )],
2321                                      'vars'=>[qw( x y )]
2322                                     );
2323     }
2324
2325     @xt=$I2P->translate($opts{'xexpr'});
2326     @yt=$I2P->translate($opts{'yexpr'});
2327
2328     $numre=$I2P->{'numre'};
2329     @pt=(0,0);
2330
2331     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2332     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2333     @{$opts{'parm'}}=@pt;
2334   }
2335
2336 #  print Dumper(\%opts);
2337
2338   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2339     $self->{ERRSTR}='transform: no xopcodes given.';
2340     return undef;
2341   }
2342
2343   @op=@{$opts{'xopcodes'}};
2344   for $iop (@op) {
2345     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2346       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2347       return undef;
2348     }
2349     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2350   }
2351
2352
2353 # yopcopdes
2354
2355   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2356     $self->{ERRSTR}='transform: no yopcodes given.';
2357     return undef;
2358   }
2359
2360   @op=@{$opts{'yopcodes'}};
2361   for $iop (@op) {
2362     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2363       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2364       return undef;
2365     }
2366     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2367   }
2368
2369 #parameters
2370
2371   if ( !exists $opts{'parm'}) {
2372     $self->{ERRSTR}='transform: no parameter arg given.';
2373     return undef;
2374   }
2375
2376 #  print Dumper(\@ropx);
2377 #  print Dumper(\@ropy);
2378 #  print Dumper(\@ropy);
2379
2380   my $img = Imager->new();
2381   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2382   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2383   return $img;
2384 }
2385
2386
2387 sub transform2 {
2388   my ($opts, @imgs) = @_;
2389
2390   require "Imager/Expr.pm";
2391
2392   $opts->{variables} = [ qw(x y) ];
2393   my ($width, $height) = @{$opts}{qw(width height)};
2394   if (@imgs) {
2395     $width ||= $imgs[0]->getwidth();
2396     $height ||= $imgs[0]->getheight();
2397     my $img_num = 1;
2398     for my $img (@imgs) {
2399       $opts->{constants}{"w$img_num"} = $img->getwidth();
2400       $opts->{constants}{"h$img_num"} = $img->getheight();
2401       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2402       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2403       ++$img_num;
2404     }
2405   }
2406   if ($width) {
2407     $opts->{constants}{w} = $width;
2408     $opts->{constants}{cx} = $width/2;
2409   }
2410   else {
2411     $Imager::ERRSTR = "No width supplied";
2412     return;
2413   }
2414   if ($height) {
2415     $opts->{constants}{h} = $height;
2416     $opts->{constants}{cy} = $height/2;
2417   }
2418   else {
2419     $Imager::ERRSTR = "No height supplied";
2420     return;
2421   }
2422   my $code = Imager::Expr->new($opts);
2423   if (!$code) {
2424     $Imager::ERRSTR = Imager::Expr::error();
2425     return;
2426   }
2427   my $channels = $opts->{channels} || 3;
2428   unless ($channels >= 1 && $channels <= 4) {
2429     return Imager->_set_error("channels must be an integer between 1 and 4");
2430   }
2431
2432   my $img = Imager->new();
2433   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2434                              $channels, $code->code(),
2435                              $code->nregs(), $code->cregs(),
2436                              [ map { $_->{IMG} } @imgs ]);
2437   if (!defined $img->{IMG}) {
2438     $Imager::ERRSTR = Imager->_error_as_msg();
2439     return;
2440   }
2441
2442   return $img;
2443 }
2444
2445 sub rubthrough {
2446   my $self=shift;
2447   my %opts= @_;
2448
2449   unless ($self->{IMG}) {
2450     $self->{ERRSTR}='empty input image';
2451     return undef;
2452   }
2453   unless ($opts{src} && $opts{src}->{IMG}) {
2454     $self->{ERRSTR}='empty input image for src';
2455     return undef;
2456   }
2457
2458   %opts = (src_minx => 0,
2459            src_miny => 0,
2460            src_maxx => $opts{src}->getwidth(),
2461            src_maxy => $opts{src}->getheight(),
2462            %opts);
2463
2464   my $tx = $opts{tx};
2465   defined $tx or $tx = $opts{left};
2466   defined $tx or $tx = 0;
2467
2468   my $ty = $opts{ty};
2469   defined $ty or $ty = $opts{top};
2470   defined $ty or $ty = 0;
2471
2472   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
2473                     $opts{src_minx}, $opts{src_miny},
2474                     $opts{src_maxx}, $opts{src_maxy})) {
2475     $self->_set_error($self->_error_as_msg());
2476     return undef;
2477   }
2478
2479   return $self;
2480 }
2481
2482 sub compose {
2483   my $self = shift;
2484   my %opts =
2485     (
2486      opacity => 1.0,
2487      mask_left => 0,
2488      mask_top => 0,
2489      @_
2490     );
2491
2492   unless ($self->{IMG}) {
2493     $self->_set_error("compose: empty input image");
2494     return;
2495   }
2496
2497   unless ($opts{src}) {
2498     $self->_set_error("compose: src parameter missing");
2499     return;
2500   }
2501
2502   unless ($opts{src}{IMG}) {
2503     $self->_set_error("compose: src parameter empty image");
2504     return;
2505   }
2506   my $src = $opts{src};
2507
2508   my $left = $opts{left};
2509   defined $left or $left = $opts{tx};
2510   defined $left or $left = 0;
2511
2512   my $top = $opts{top};
2513   defined $top or $top = $opts{ty};
2514   defined $top or $top = 0;
2515
2516   my $src_left = $opts{src_left};
2517   defined $src_left or $src_left = $opts{src_minx};
2518   defined $src_left or $src_left = 0;
2519
2520   my $src_top = $opts{src_top};
2521   defined $src_top or $src_top = $opts{src_miny};
2522   defined $src_top or $src_top = 0;
2523
2524   my $width = $opts{width};
2525   if (!defined $width && defined $opts{src_maxx}) {
2526     $width = $opts{src_maxx} - $src_left;
2527   }
2528   defined $width or $width = $src->getwidth() - $src_left;
2529
2530   my $height = $opts{height};
2531   if (!defined $height && defined $opts{src_maxy}) {
2532     $height = $opts{src_maxy} - $src_top;
2533   }
2534   defined $height or $height = $src->getheight() - $src_top;
2535
2536   my $combine = $self->_combine($opts{combine}, 'normal');
2537
2538   if ($opts{mask}) {
2539     unless ($opts{mask}{IMG}) {
2540       $self->_set_error("compose: mask parameter empty image");
2541       return;
2542     }
2543
2544     my $mask_left = $opts{mask_left};
2545     defined $mask_left or $mask_left = $opts{mask_minx};
2546     defined $mask_left or $mask_left = 0;
2547
2548     my $mask_top = $opts{mask_top};
2549     defined $mask_top or $mask_top = $opts{mask_miny};
2550     defined $mask_top or $mask_top = 0;
2551
2552     i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
2553                    $left, $top, $src_left, $src_top,
2554                    $mask_left, $mask_top, $width, $height,
2555                    $combine, $opts{opacity})
2556       or return;
2557   }
2558   else {
2559     i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2560               $width, $height, $combine, $opts{opacity})
2561       or return;
2562   }
2563
2564   return $self;
2565 }
2566
2567 sub flip {
2568   my $self  = shift;
2569   my %opts  = @_;
2570   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2571   my $dir;
2572   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2573   $dir = $xlate{$opts{'dir'}};
2574   return $self if i_flipxy($self->{IMG}, $dir);
2575   return ();
2576 }
2577
2578 sub rotate {
2579   my $self = shift;
2580   my %opts = @_;
2581
2582   unless (defined wantarray) {
2583     my @caller = caller;
2584     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2585     return;
2586   }
2587
2588   if (defined $opts{right}) {
2589     my $degrees = $opts{right};
2590     if ($degrees < 0) {
2591       $degrees += 360 * int(((-$degrees)+360)/360);
2592     }
2593     $degrees = $degrees % 360;
2594     if ($degrees == 0) {
2595       return $self->copy();
2596     }
2597     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2598       my $result = Imager->new();
2599       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2600         return $result;
2601       }
2602       else {
2603         $self->{ERRSTR} = $self->_error_as_msg();
2604         return undef;
2605       }
2606     }
2607     else {
2608       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2609       return undef;
2610     }
2611   }
2612   elsif (defined $opts{radians} || defined $opts{degrees}) {
2613     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2614
2615     my $back = $opts{back};
2616     my $result = Imager->new;
2617     if ($back) {
2618       $back = _color($back);
2619       unless ($back) {
2620         $self->_set_error(Imager->errstr);
2621         return undef;
2622       }
2623
2624       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2625     }
2626     else {
2627       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2628     }
2629     if ($result->{IMG}) {
2630       return $result;
2631     }
2632     else {
2633       $self->{ERRSTR} = $self->_error_as_msg();
2634       return undef;
2635     }
2636   }
2637   else {
2638     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2639     return undef;
2640   }
2641 }
2642
2643 sub matrix_transform {
2644   my $self = shift;
2645   my %opts = @_;
2646
2647   unless (defined wantarray) {
2648     my @caller = caller;
2649     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2650     return;
2651   }
2652
2653   if ($opts{matrix}) {
2654     my $xsize = $opts{xsize} || $self->getwidth;
2655     my $ysize = $opts{ysize} || $self->getheight;
2656
2657     my $result = Imager->new;
2658     if ($opts{back}) {
2659       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2660                                           $opts{matrix}, $opts{back})
2661         or return undef;
2662     }
2663     else {
2664       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2665                                           $opts{matrix})
2666         or return undef;
2667     }
2668
2669     return $result;
2670   }
2671   else {
2672     $self->{ERRSTR} = "matrix parameter required";
2673     return undef;
2674   }
2675 }
2676
2677 # blame Leolo :)
2678 *yatf = \&matrix_transform;
2679
2680 # These two are supported for legacy code only
2681
2682 sub i_color_new {
2683   return Imager::Color->new(@_);
2684 }
2685
2686 sub i_color_set {
2687   return Imager::Color::set(@_);
2688 }
2689
2690 # Draws a box between the specified corner points.
2691 sub box {
2692   my $self=shift;
2693   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2694   my $dflcl=i_color_new(255,255,255,255);
2695   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2696
2697   if (exists $opts{'box'}) {
2698     $opts{'xmin'} = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2699     $opts{'xmax'} = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2700     $opts{'ymin'} = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2701     $opts{'ymax'} = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2702   }
2703
2704   if ($opts{filled}) {
2705     my $color = _color($opts{'color'});
2706     unless ($color) {
2707       $self->{ERRSTR} = $Imager::ERRSTR;
2708       return;
2709     }
2710     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2711                  $opts{ymax}, $color);
2712   }
2713   elsif ($opts{fill}) {
2714     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2715       # assume it's a hash ref
2716       require 'Imager/Fill.pm';
2717       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2718         $self->{ERRSTR} = $Imager::ERRSTR;
2719         return undef;
2720       }
2721     }
2722     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2723                 $opts{ymax},$opts{fill}{fill});
2724   }
2725   else {
2726     my $color = _color($opts{'color'});
2727     unless ($color) {
2728       $self->{ERRSTR} = $Imager::ERRSTR;
2729       return;
2730     }
2731     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2732           $color);
2733   }
2734   return $self;
2735 }
2736
2737 sub arc {
2738   my $self=shift;
2739   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2740   my $dflcl=i_color_new(255,255,255,255);
2741   my %opts=(color=>$dflcl,
2742             'r'=>_min($self->getwidth(),$self->getheight())/3,
2743             'x'=>$self->getwidth()/2,
2744             'y'=>$self->getheight()/2,
2745             'd1'=>0, 'd2'=>361, @_);
2746   if ($opts{aa}) {
2747     if ($opts{fill}) {
2748       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2749         # assume it's a hash ref
2750         require 'Imager/Fill.pm';
2751         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2752           $self->{ERRSTR} = $Imager::ERRSTR;
2753           return;
2754         }
2755       }
2756       i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2757                      $opts{'d2'}, $opts{fill}{fill});
2758     }
2759     else {
2760       my $color = _color($opts{'color'});
2761       unless ($color) {
2762         $self->{ERRSTR} = $Imager::ERRSTR;
2763         return;
2764       }
2765       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2766         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2767                     $color);
2768       }
2769       else {
2770         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2771                  $opts{'d1'}, $opts{'d2'}, $color);
2772       }
2773     }
2774   }
2775   else {
2776     if ($opts{fill}) {
2777       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2778         # assume it's a hash ref
2779         require 'Imager/Fill.pm';
2780         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2781           $self->{ERRSTR} = $Imager::ERRSTR;
2782           return;
2783         }
2784       }
2785       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2786                   $opts{'d2'}, $opts{fill}{fill});
2787     }
2788     else {
2789       my $color = _color($opts{'color'});
2790       unless ($color) {
2791         $self->{ERRSTR} = $Imager::ERRSTR;
2792         return;
2793       }
2794       i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2795             $opts{'d1'}, $opts{'d2'}, $color);
2796     }
2797   }
2798
2799   return $self;
2800 }
2801
2802 # Draws a line from one point to the other
2803 # the endpoint is set if the endp parameter is set which it is by default.
2804 # to turn of the endpoint being set use endp=>0 when calling line.
2805
2806 sub line {
2807   my $self=shift;
2808   my $dflcl=i_color_new(0,0,0,0);
2809   my %opts=(color=>$dflcl,
2810             endp => 1,
2811             @_);
2812   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2813
2814   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2815   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2816
2817   my $color = _color($opts{'color'});
2818   unless ($color) {
2819     $self->{ERRSTR} = $Imager::ERRSTR;
2820     return;
2821   }
2822
2823   $opts{antialias} = $opts{aa} if defined $opts{aa};
2824   if ($opts{antialias}) {
2825     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2826               $color, $opts{endp});
2827   } else {
2828     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2829            $color, $opts{endp});
2830   }
2831   return $self;
2832 }
2833
2834 # Draws a line between an ordered set of points - It more or less just transforms this
2835 # into a list of lines.
2836
2837 sub polyline {
2838   my $self=shift;
2839   my ($pt,$ls,@points);
2840   my $dflcl=i_color_new(0,0,0,0);
2841   my %opts=(color=>$dflcl,@_);
2842
2843   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2844
2845   if (exists($opts{points})) { @points=@{$opts{points}}; }
2846   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2847     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2848     }
2849
2850 #  print Dumper(\@points);
2851
2852   my $color = _color($opts{'color'});
2853   unless ($color) {
2854     $self->{ERRSTR} = $Imager::ERRSTR;
2855     return;
2856   }
2857   $opts{antialias} = $opts{aa} if defined $opts{aa};
2858   if ($opts{antialias}) {
2859     for $pt(@points) {
2860       if (defined($ls)) {
2861         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2862       }
2863       $ls=$pt;
2864     }
2865   } else {
2866     for $pt(@points) {
2867       if (defined($ls)) {
2868         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2869       }
2870       $ls=$pt;
2871     }
2872   }
2873   return $self;
2874 }
2875
2876 sub polygon {
2877   my $self = shift;
2878   my ($pt,$ls,@points);
2879   my $dflcl = i_color_new(0,0,0,0);
2880   my %opts = (color=>$dflcl, @_);
2881
2882   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2883
2884   if (exists($opts{points})) {
2885     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2886     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2887   }
2888
2889   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2890     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2891   }
2892
2893   if ($opts{'fill'}) {
2894     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2895       # assume it's a hash ref
2896       require 'Imager/Fill.pm';
2897       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2898         $self->{ERRSTR} = $Imager::ERRSTR;
2899         return undef;
2900       }
2901     }
2902     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2903                     $opts{'fill'}{'fill'});
2904   }
2905   else {
2906     my $color = _color($opts{'color'});
2907     unless ($color) {
2908       $self->{ERRSTR} = $Imager::ERRSTR;
2909       return;
2910     }
2911     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2912   }
2913
2914   return $self;
2915 }
2916
2917
2918 # this the multipoint bezier curve
2919 # this is here more for testing that actual usage since
2920 # this is not a good algorithm.  Usually the curve would be
2921 # broken into smaller segments and each done individually.
2922
2923 sub polybezier {
2924   my $self=shift;
2925   my ($pt,$ls,@points);
2926   my $dflcl=i_color_new(0,0,0,0);
2927   my %opts=(color=>$dflcl,@_);
2928
2929   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2930
2931   if (exists $opts{points}) {
2932     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2933     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2934   }
2935
2936   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2937     $self->{ERRSTR}='Missing or invalid points.';
2938     return;
2939   }
2940
2941   my $color = _color($opts{'color'});
2942   unless ($color) {
2943     $self->{ERRSTR} = $Imager::ERRSTR;
2944     return;
2945   }
2946   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2947   return $self;
2948 }
2949
2950 sub flood_fill {
2951   my $self = shift;
2952   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2953   my $rc;
2954
2955   unless (exists $opts{'x'} && exists $opts{'y'}) {
2956     $self->{ERRSTR} = "missing seed x and y parameters";
2957     return undef;
2958   }
2959
2960   if ($opts{border}) {
2961     my $border = _color($opts{border});
2962     unless ($border) {
2963       $self->_set_error($Imager::ERRSTR);
2964       return;
2965     }
2966     if ($opts{fill}) {
2967       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2968         # assume it's a hash ref
2969         require Imager::Fill;
2970         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2971           $self->{ERRSTR} = $Imager::ERRSTR;
2972           return;
2973         }
2974       }
2975       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2976                                  $opts{fill}{fill}, $border);
2977     }
2978     else {
2979       my $color = _color($opts{'color'});
2980       unless ($color) {
2981         $self->{ERRSTR} = $Imager::ERRSTR;
2982         return;
2983       }
2984       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2985                                 $color, $border);
2986     }
2987     if ($rc) {
2988       return $self;
2989     }
2990     else {
2991       $self->{ERRSTR} = $self->_error_as_msg();
2992       return;
2993     }
2994   }
2995   else {
2996     if ($opts{fill}) {
2997       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2998         # assume it's a hash ref
2999         require 'Imager/Fill.pm';
3000         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3001           $self->{ERRSTR} = $Imager::ERRSTR;
3002           return;
3003         }
3004       }
3005       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3006     }
3007     else {
3008       my $color = _color($opts{'color'});
3009       unless ($color) {
3010         $self->{ERRSTR} = $Imager::ERRSTR;
3011         return;
3012       }
3013       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3014     }
3015     if ($rc) {
3016       return $self;
3017     }
3018     else {
3019       $self->{ERRSTR} = $self->_error_as_msg();
3020       return;
3021     }
3022   }
3023 }
3024
3025 sub setpixel {
3026   my $self = shift;
3027
3028   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
3029
3030   unless (exists $opts{'x'} && exists $opts{'y'}) {
3031     $self->{ERRSTR} = 'missing x and y parameters';
3032     return undef;
3033   }
3034
3035   my $x = $opts{'x'};
3036   my $y = $opts{'y'};
3037   my $color = _color($opts{color})
3038     or return undef;
3039   if (ref $x && ref $y) {
3040     unless (@$x == @$y) {
3041       $self->{ERRSTR} = 'length of x and y mismatch';
3042       return;
3043     }
3044     my $set = 0;
3045     if ($color->isa('Imager::Color')) {
3046       for my $i (0..$#{$opts{'x'}}) {
3047         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3048           or ++$set;
3049       }
3050     }
3051     else {
3052       for my $i (0..$#{$opts{'x'}}) {
3053         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3054           or ++$set;
3055       }
3056     }
3057     $set or return;
3058     return $set;
3059   }
3060   else {
3061     if ($color->isa('Imager::Color')) {
3062       i_ppix($self->{IMG}, $x, $y, $color)
3063         and return;
3064     }
3065     else {
3066       i_ppixf($self->{IMG}, $x, $y, $color)
3067         and return;
3068     }
3069   }
3070
3071   $self;
3072 }
3073
3074 sub getpixel {
3075   my $self = shift;
3076
3077   my %opts = ( "type"=>'8bit', @_);
3078
3079   unless (exists $opts{'x'} && exists $opts{'y'}) {
3080     $self->{ERRSTR} = 'missing x and y parameters';
3081     return undef;
3082   }
3083
3084   my $x = $opts{'x'};
3085   my $y = $opts{'y'};
3086   if (ref $x && ref $y) {
3087     unless (@$x == @$y) {
3088       $self->{ERRSTR} = 'length of x and y mismatch';
3089       return undef;
3090     }
3091     my @result;
3092     if ($opts{"type"} eq '8bit') {
3093       for my $i (0..$#{$opts{'x'}}) {
3094         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3095       }
3096     }
3097     else {
3098       for my $i (0..$#{$opts{'x'}}) {
3099         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3100       }
3101     }
3102     return wantarray ? @result : \@result;
3103   }
3104   else {
3105     if ($opts{"type"} eq '8bit') {
3106       return i_get_pixel($self->{IMG}, $x, $y);
3107     }
3108     else {
3109       return i_gpixf($self->{IMG}, $x, $y);
3110     }
3111   }
3112
3113   $self;
3114 }
3115
3116 sub getscanline {
3117   my $self = shift;
3118   my %opts = ( type => '8bit', x=>0, @_);
3119
3120   $self->_valid_image or return;
3121
3122   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3123
3124   unless (defined $opts{'y'}) {
3125     $self->_set_error("missing y parameter");
3126     return;
3127   }
3128
3129   if ($opts{type} eq '8bit') {
3130     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3131                   $opts{'y'});
3132   }
3133   elsif ($opts{type} eq 'float') {
3134     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3135                   $opts{'y'});
3136   }
3137   elsif ($opts{type} eq 'index') {
3138     unless (i_img_type($self->{IMG})) {
3139       $self->_set_error("type => index only valid on paletted images");
3140       return;
3141     }
3142     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3143                   $opts{'y'});
3144   }
3145   else {
3146     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3147     return;
3148   }
3149 }
3150
3151 sub setscanline {
3152   my $self = shift;
3153   my %opts = ( x=>0, @_);
3154
3155   $self->_valid_image or return;
3156
3157   unless (defined $opts{'y'}) {
3158     $self->_set_error("missing y parameter");
3159     return;
3160   }
3161
3162   if (!$opts{type}) {
3163     if (ref $opts{pixels} && @{$opts{pixels}}) {
3164       # try to guess the type
3165       if ($opts{pixels}[0]->isa('Imager::Color')) {
3166         $opts{type} = '8bit';
3167       }
3168       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3169         $opts{type} = 'float';
3170       }
3171       else {
3172         $self->_set_error("missing type parameter and could not guess from pixels");
3173         return;
3174       }
3175     }
3176     else {
3177       # default
3178       $opts{type} = '8bit';
3179     }
3180   }
3181
3182   if ($opts{type} eq '8bit') {
3183     if (ref $opts{pixels}) {
3184       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3185     }
3186     else {
3187       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3188     }
3189   }
3190   elsif ($opts{type} eq 'float') {
3191     if (ref $opts{pixels}) {
3192       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3193     }
3194     else {
3195       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3196     }
3197   }
3198   elsif ($opts{type} eq 'index') {
3199     if (ref $opts{pixels}) {
3200       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3201     }
3202     else {
3203       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3204     }
3205   }
3206   else {
3207     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3208     return;
3209   }
3210 }
3211
3212 sub getsamples {
3213   my $self = shift;
3214   my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3215
3216   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3217
3218   unless (defined $opts{'y'}) {
3219     $self->_set_error("missing y parameter");
3220     return;
3221   }
3222
3223   unless ($opts{channels}) {
3224     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3225   }
3226
3227   if ($opts{target}) {
3228     my $target = $opts{target};
3229     my $offset = $opts{offset};
3230     if ($opts{type} eq '8bit') {
3231       my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3232                             $opts{y}, @{$opts{channels}})
3233         or return;
3234       @{$target}{$offset .. $offset + @samples - 1} = @samples;
3235       return scalar(@samples);
3236     }
3237     elsif ($opts{type} eq 'float') {
3238       my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3239                              $opts{y}, @{$opts{channels}});
3240       @{$target}{$offset .. $offset + @samples - 1} = @samples;
3241       return scalar(@samples);
3242     }
3243     elsif ($opts{type} =~ /^(\d+)bit$/) {
3244       my $bits = $1;
3245
3246       my @data;
3247       my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3248                                $opts{y}, $bits, $target,
3249                                $offset, @{$opts{channels}});
3250       unless (defined $count) {
3251         $self->_set_error(Imager->_error_as_msg);
3252         return;
3253       }
3254
3255       return $count;
3256     }
3257     else {
3258       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3259       return;
3260     }
3261   }
3262   else {
3263     if ($opts{type} eq '8bit') {
3264       return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3265                      $opts{y}, @{$opts{channels}});
3266     }
3267     elsif ($opts{type} eq 'float') {
3268       return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3269                       $opts{y}, @{$opts{channels}});
3270     }
3271     elsif ($opts{type} =~ /^(\d+)bit$/) {
3272       my $bits = $1;
3273
3274       my @data;
3275       i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3276                    $opts{y}, $bits, \@data, 0, @{$opts{channels}})
3277         or return;
3278       return @data;
3279     }
3280     else {
3281       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3282       return;
3283     }
3284   }
3285 }
3286
3287 sub setsamples {
3288   my $self = shift;
3289   my %opts = ( x => 0, offset => 0, @_ );
3290
3291   unless ($self->{IMG}) {
3292     $self->_set_error('setsamples: empty input image');
3293     return;
3294   }
3295
3296   unless(defined $opts{data} && ref $opts{data}) {
3297     $self->_set_error('setsamples: data parameter missing or invalid');
3298     return;
3299   }
3300
3301   unless ($opts{channels}) {
3302     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3303   }
3304
3305   unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) {
3306     $self->_set_error('setsamples: type parameter missing or invalid');
3307     return;
3308   }
3309   my $bits = $1;
3310
3311   unless (defined $opts{width}) {
3312     $opts{width} = $self->getwidth() - $opts{x};
3313   }
3314
3315   my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3316                            $opts{channels}, $opts{data}, $opts{offset},
3317                            $opts{width});
3318   unless (defined $count) {
3319     $self->_set_error(Imager->_error_as_msg);
3320     return;
3321   }
3322
3323   return $count;
3324 }
3325
3326 # make an identity matrix of the given size
3327 sub _identity {
3328   my ($size) = @_;
3329
3330   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3331   for my $c (0 .. ($size-1)) {
3332     $matrix->[$c][$c] = 1;
3333   }
3334   return $matrix;
3335 }
3336
3337 # general function to convert an image
3338 sub convert {
3339   my ($self, %opts) = @_;
3340   my $matrix;
3341
3342   unless (defined wantarray) {
3343     my @caller = caller;
3344     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3345     return;
3346   }
3347
3348   # the user can either specify a matrix or preset
3349   # the matrix overrides the preset
3350   if (!exists($opts{matrix})) {
3351     unless (exists($opts{preset})) {
3352       $self->{ERRSTR} = "convert() needs a matrix or preset";
3353       return;
3354     }
3355     else {
3356       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3357         # convert to greyscale, keeping the alpha channel if any
3358         if ($self->getchannels == 3) {
3359           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3360         }
3361         elsif ($self->getchannels == 4) {
3362           # preserve the alpha channel
3363           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3364                       [ 0,     0,     0,     1 ] ];
3365         }
3366         else {
3367           # an identity
3368           $matrix = _identity($self->getchannels);
3369         }
3370       }
3371       elsif ($opts{preset} eq 'noalpha') {
3372         # strip the alpha channel
3373         if ($self->getchannels == 2 or $self->getchannels == 4) {
3374           $matrix = _identity($self->getchannels);
3375           pop(@$matrix); # lose the alpha entry
3376         }
3377         else {
3378           $matrix = _identity($self->getchannels);
3379         }
3380       }
3381       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3382         # extract channel 0
3383         $matrix = [ [ 1 ] ];
3384       }
3385       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3386         $matrix = [ [ 0, 1 ] ];
3387       }
3388       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3389         $matrix = [ [ 0, 0, 1 ] ];
3390       }
3391       elsif ($opts{preset} eq 'alpha') {
3392         if ($self->getchannels == 2 or $self->getchannels == 4) {
3393           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3394         }
3395         else {
3396           # the alpha is just 1 <shrug>
3397           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3398         }
3399       }
3400       elsif ($opts{preset} eq 'rgb') {
3401         if ($self->getchannels == 1) {
3402           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3403         }
3404         elsif ($self->getchannels == 2) {
3405           # preserve the alpha channel
3406           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3407         }
3408         else {
3409           $matrix = _identity($self->getchannels);
3410         }
3411       }
3412       elsif ($opts{preset} eq 'addalpha') {
3413         if ($self->getchannels == 1) {
3414           $matrix = _identity(2);
3415         }
3416         elsif ($self->getchannels == 3) {
3417           $matrix = _identity(4);
3418         }
3419         else {
3420           $matrix = _identity($self->getchannels);
3421         }
3422       }
3423       else {
3424         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3425         return undef;
3426       }
3427     }
3428   }
3429   else {
3430     $matrix = $opts{matrix};
3431   }
3432
3433   my $new = Imager->new;
3434   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3435   unless ($new->{IMG}) {
3436     # most likely a bad matrix
3437     $self->{ERRSTR} = _error_as_msg();
3438     return undef;
3439   }
3440   return $new;
3441 }
3442
3443
3444 # general function to map an image through lookup tables
3445
3446 sub map {
3447   my ($self, %opts) = @_;
3448   my @chlist = qw( red green blue alpha );
3449
3450   if (!exists($opts{'maps'})) {
3451     # make maps from channel maps
3452     my $chnum;
3453     for $chnum (0..$#chlist) {
3454       if (exists $opts{$chlist[$chnum]}) {
3455         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3456       } elsif (exists $opts{'all'}) {
3457         $opts{'maps'}[$chnum] = $opts{'all'};
3458       }
3459     }
3460   }
3461   if ($opts{'maps'} and $self->{IMG}) {
3462     i_map($self->{IMG}, $opts{'maps'} );
3463   }
3464   return $self;
3465 }
3466
3467 sub difference {
3468   my ($self, %opts) = @_;
3469
3470   defined $opts{mindist} or $opts{mindist} = 0;
3471
3472   defined $opts{other}
3473     or return $self->_set_error("No 'other' parameter supplied");
3474   defined $opts{other}{IMG}
3475     or return $self->_set_error("No image data in 'other' image");
3476
3477   $self->{IMG}
3478     or return $self->_set_error("No image data");
3479
3480   my $result = Imager->new;
3481   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3482                                 $opts{mindist})
3483     or return $self->_set_error($self->_error_as_msg());
3484
3485   return $result;
3486 }
3487
3488 # destructive border - image is shrunk by one pixel all around
3489
3490 sub border {
3491   my ($self,%opts)=@_;
3492   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3493   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3494 }
3495
3496
3497 # Get the width of an image
3498
3499 sub getwidth {
3500   my $self = shift;
3501   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3502   return (i_img_info($self->{IMG}))[0];
3503 }
3504
3505 # Get the height of an image
3506
3507 sub getheight {
3508   my $self = shift;
3509   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3510   return (i_img_info($self->{IMG}))[1];
3511 }
3512
3513 # Get number of channels in an image
3514
3515 sub getchannels {
3516   my $self = shift;
3517   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3518   return i_img_getchannels($self->{IMG});
3519 }
3520
3521 # Get channel mask
3522
3523 sub getmask {
3524   my $self = shift;
3525   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3526   return i_img_getmask($self->{IMG});
3527 }
3528
3529 # Set channel mask
3530
3531 sub setmask {
3532   my $self = shift;
3533   my %opts = @_;
3534   if (!defined($self->{IMG})) {
3535     $self->{ERRSTR} = 'image is empty';
3536     return undef;
3537   }
3538   unless (defined $opts{mask}) {
3539     $self->_set_error("mask parameter required");
3540     return;
3541   }
3542   i_img_setmask( $self->{IMG} , $opts{mask} );
3543
3544   1;
3545 }
3546
3547 # Get number of colors in an image
3548
3549 sub getcolorcount {
3550   my $self=shift;
3551   my %opts=('maxcolors'=>2**30,@_);
3552   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3553   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3554   return ($rc==-1? undef : $rc);
3555 }
3556
3557 # Returns a reference to a hash. The keys are colour named (packed) and the
3558 # values are the number of pixels in this colour.
3559 sub getcolorusagehash {
3560   my $self = shift;
3561
3562   my %opts = ( maxcolors => 2**30, @_ );
3563   my $max_colors = $opts{maxcolors};
3564   unless (defined $max_colors && $max_colors > 0) {
3565     $self->_set_error('maxcolors must be a positive integer');
3566     return;
3567   }
3568
3569   unless (defined $self->{IMG}) {
3570     $self->_set_error('empty input image');
3571     return;
3572   }
3573
3574   my $channels= $self->getchannels;
3575   # We don't want to look at the alpha channel, because some gifs using it
3576   # doesn't define it for every colour (but only for some)
3577   $channels -= 1 if $channels == 2 or $channels == 4;
3578   my %color_use;
3579   my $height = $self->getheight;
3580   for my $y (0 .. $height - 1) {
3581     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3582     while (length $colors) {
3583       $color_use{ substr($colors, 0, $channels, '') }++;
3584     }
3585     keys %color_use > $max_colors
3586       and return;
3587   }
3588   return \%color_use;
3589 }
3590
3591 # This will return a ordered array of the colour usage. Kind of the sorted
3592 # version of the values of the hash returned by getcolorusagehash.
3593 # You might want to add safety checks and change the names, etc...
3594 sub getcolorusage {
3595   my $self = shift;
3596
3597   my %opts = ( maxcolors => 2**30, @_ );
3598   my $max_colors = $opts{maxcolors};
3599   unless (defined $max_colors && $max_colors > 0) {
3600     $self->_set_error('maxcolors must be a positive integer');
3601     return;
3602   }
3603
3604   unless (defined $self->{IMG}) {
3605     $self->_set_error('empty input image');
3606     return undef;
3607   }
3608
3609   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3610 }
3611
3612 # draw string to an image
3613
3614 sub string {
3615   my $self = shift;
3616   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3617
3618   my %input=('x'=>0, 'y'=>0, @_);
3619   defined($input{string}) or $input{string} = $input{text};
3620
3621   unless(defined $input{string}) {
3622     $self->{ERRSTR}="missing required parameter 'string'";
3623     return;
3624   }
3625
3626   unless($input{font}) {
3627     $self->{ERRSTR}="missing required parameter 'font'";
3628     return;
3629   }
3630
3631   unless ($input{font}->draw(image=>$self, %input)) {
3632     return;
3633   }
3634
3635   return $self;
3636 }
3637
3638 sub align_string {
3639   my $self = shift;
3640
3641   my $img;
3642   if (ref $self) {
3643     unless ($self->{IMG}) {
3644       $self->{ERRSTR}='empty input image';
3645       return;
3646     }
3647     $img = $self;
3648   }
3649   else {
3650     $img = undef;
3651   }
3652
3653   my %input=('x'=>0, 'y'=>0, @_);
3654   $input{string}||=$input{text};
3655
3656   unless(exists $input{string}) {
3657     $self->_set_error("missing required parameter 'string'");
3658     return;
3659   }
3660
3661   unless($input{font}) {
3662     $self->_set_error("missing required parameter 'font'");
3663     return;
3664   }
3665
3666   my @result;
3667   unless (@result = $input{font}->align(image=>$img, %input)) {
3668     return;
3669   }
3670
3671   return wantarray ? @result : $result[0];
3672 }
3673
3674 my @file_limit_names = qw/width height bytes/;
3675
3676 sub set_file_limits {
3677   shift;
3678
3679   my %opts = @_;
3680   my %values;
3681
3682   if ($opts{reset}) {
3683     @values{@file_limit_names} = (0) x @file_limit_names;
3684   }
3685   else {
3686     @values{@file_limit_names} = i_get_image_file_limits();
3687   }
3688
3689   for my $key (keys %values) {
3690     defined $opts{$key} and $values{$key} = $opts{$key};
3691   }
3692
3693   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3694 }
3695
3696 sub get_file_limits {
3697   i_get_image_file_limits();
3698 }
3699
3700 # Shortcuts that can be exported
3701
3702 sub newcolor { Imager::Color->new(@_); }
3703 sub newfont  { Imager::Font->new(@_); }
3704 sub NCF { Imager::Color::Float->new(@_) }
3705
3706 *NC=*newcolour=*newcolor;
3707 *NF=*newfont;
3708
3709 *open=\&read;
3710 *circle=\&arc;
3711
3712
3713 #### Utility routines
3714
3715 sub errstr {
3716   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3717 }
3718
3719 sub _set_error {
3720   my ($self, $msg) = @_;
3721
3722   if (ref $self) {
3723     $self->{ERRSTR} = $msg;
3724   }
3725   else {
3726     $ERRSTR = $msg;
3727   }
3728   return;
3729 }
3730
3731 # Default guess for the type of an image from extension
3732
3733 sub def_guess_type {
3734   my $name=lc(shift);
3735   my $ext;
3736   $ext=($name =~ m/\.([^\.]+)$/)[0];
3737   return 'tiff' if ($ext =~ m/^tiff?$/);
3738   return 'jpeg' if ($ext =~ m/^jpe?g$/);
3739   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
3740   return 'png'  if ($ext eq "png");
3741   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
3742   return 'tga'  if ($ext eq "tga");
3743   return 'sgi'  if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
3744   return 'gif'  if ($ext eq "gif");
3745   return 'raw'  if ($ext eq "raw");
3746   return lc $ext; # best guess
3747   return ();
3748 }
3749
3750 sub combines {
3751   return @combine_types;
3752 }
3753
3754 # get the minimum of a list
3755
3756 sub _min {
3757   my $mx=shift;
3758   for(@_) { if ($_<$mx) { $mx=$_; }}
3759   return $mx;
3760 }
3761
3762 # get the maximum of a list
3763
3764 sub _max {
3765   my $mx=shift;
3766   for(@_) { if ($_>$mx) { $mx=$_; }}
3767   return $mx;
3768 }
3769
3770 # string stuff for iptc headers
3771
3772 sub _clean {
3773   my($str)=$_[0];
3774   $str = substr($str,3);
3775   $str =~ s/[\n\r]//g;
3776   $str =~ s/\s+/ /g;
3777   $str =~ s/^\s//;
3778   $str =~ s/\s$//;
3779   return $str;
3780 }
3781
3782 # A little hack to parse iptc headers.
3783
3784 sub parseiptc {
3785   my $self=shift;
3786   my(@sar,$item,@ar);
3787   my($caption,$photogr,$headln,$credit);
3788
3789   my $str=$self->{IPTCRAW};
3790
3791   defined $str
3792     or return;
3793
3794   @ar=split(/8BIM/,$str);
3795
3796   my $i=0;
3797   foreach (@ar) {
3798     if (/^\004\004/) {
3799       @sar=split(/\034\002/);
3800       foreach $item (@sar) {
3801         if ($item =~ m/^x/) {
3802           $caption = _clean($item);
3803           $i++;
3804         }
3805         if ($item =~ m/^P/) {
3806           $photogr = _clean($item);
3807           $i++;
3808         }
3809         if ($item =~ m/^i/) {
3810           $headln = _clean($item);
3811           $i++;
3812         }
3813         if ($item =~ m/^n/) {
3814           $credit = _clean($item);
3815           $i++;
3816         }
3817       }
3818     }
3819   }
3820   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3821 }
3822
3823 sub Inline {
3824   my ($lang) = @_;
3825
3826   $lang eq 'C'
3827     or die "Only C language supported";
3828
3829   require Imager::ExtUtils;
3830   return Imager::ExtUtils->inline_config;
3831 }
3832
3833 1;
3834 __END__
3835 # Below is the stub of documentation for your module. You better edit it!
3836
3837 =head1 NAME
3838
3839 Imager - Perl extension for Generating 24 bit Images
3840
3841 =head1 SYNOPSIS
3842
3843   # Thumbnail example
3844
3845   #!/usr/bin/perl -w
3846   use strict;
3847   use Imager;
3848
3849   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3850   my $file = shift;
3851
3852   my $format;
3853
3854   my $img = Imager->new();
3855   # see Imager::Files for information on the read() method
3856   $img->read(file=>$file) or die $img->errstr();
3857
3858   $file =~ s/\.[^.]*$//;
3859
3860   # Create smaller version
3861   # documented in Imager::Transformations
3862   my $thumb = $img->scale(scalefactor=>.3);
3863
3864   # Autostretch individual channels
3865   $thumb->filter(type=>'autolevels');
3866
3867   # try to save in one of these formats
3868   SAVE:
3869
3870   for $format ( qw( png gif jpg tiff ppm ) ) {
3871     # Check if given format is supported
3872     if ($Imager::formats{$format}) {
3873       $file.="_low.$format";
3874       print "Storing image as: $file\n";
3875       # documented in Imager::Files
3876       $thumb->write(file=>$file) or
3877         die $thumb->errstr;
3878       last SAVE;
3879     }
3880   }
3881
3882 =head1 DESCRIPTION
3883
3884 Imager is a module for creating and altering images.  It can read and
3885 write various image formats, draw primitive shapes like lines,and
3886 polygons, blend multiple images together in various ways, scale, crop,
3887 render text and more.
3888
3889 =head2 Overview of documentation
3890
3891 =over
3892
3893 =item *
3894
3895 Imager - This document - Synopsis, Example, Table of Contents and
3896 Overview.
3897
3898 =item *
3899
3900 L<Imager::Tutorial> - a brief introduction to Imager.
3901
3902 =item *
3903
3904 L<Imager::Cookbook> - how to do various things with Imager.
3905
3906 =item *
3907
3908 L<Imager::ImageTypes> - Basics of constructing image objects with
3909 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
3910 8/16/double bits/channel, color maps, channel masks, image tags, color
3911 quantization.  Also discusses basic image information methods.
3912
3913 =item *
3914
3915 L<Imager::Files> - IO interaction, reading/writing images, format
3916 specific tags.
3917
3918 =item *
3919
3920 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
3921 flood fill.
3922
3923 =item *
3924
3925 L<Imager::Color> - Color specification.
3926
3927 =item *
3928
3929 L<Imager::Fill> - Fill pattern specification.
3930
3931 =item *
3932
3933 L<Imager::Font> - General font rendering, bounding boxes and font
3934 metrics.
3935
3936 =item *
3937
3938 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
3939 blending, pasting, convert and map.
3940
3941 =item *
3942
3943 L<Imager::Engines> - Programmable transformations through
3944 C<transform()>, C<transform2()> and C<matrix_transform()>.
3945
3946 =item *
3947
3948 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
3949 filter plugins.
3950
3951 =item *
3952
3953 L<Imager::Expr> - Expressions for evaluation engine used by
3954 transform2().
3955
3956 =item *
3957
3958 L<Imager::Matrix2d> - Helper class for affine transformations.
3959
3960 =item *
3961
3962 L<Imager::Fountain> - Helper for making gradient profiles.
3963
3964 =item *
3965
3966 L<Imager::API> - using Imager's C API
3967
3968 =item *
3969
3970 L<Imager::APIRef> - API function reference
3971
3972 =item *
3973
3974 L<Imager::Inline> - using Imager's C API from Inline::C
3975
3976 =item *
3977
3978 L<Imager::ExtUtils> - tools to get access to Imager's C API.
3979
3980 =back
3981
3982 =head2 Basic Overview
3983
3984 An Image object is created with C<$img = Imager-E<gt>new()>.
3985 Examples:
3986
3987   $img=Imager->new();                         # create empty image
3988   $img->read(file=>'lena.png',type=>'png') or # read image from file
3989      die $img->errstr();                      # give an explanation
3990                                               # if something failed
3991
3992 or if you want to create an empty image:
3993
3994   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3995
3996 This example creates a completely black image of width 400 and height
3997 300 and 4 channels.
3998
3999 =head1 ERROR HANDLING
4000
4001 In general a method will return false when it fails, if it does use
4002 the errstr() method to find out why:
4003
4004 =over
4005
4006 =item errstr
4007
4008 Returns the last error message in that context.
4009
4010 If the last error you received was from calling an object method, such
4011 as read, call errstr() as an object method to find out why:
4012
4013   my $image = Imager->new;
4014   $image->read(file => 'somefile.gif')
4015      or die $image->errstr;
4016
4017 If it was a class method then call errstr() as a class method:
4018
4019   my @imgs = Imager->read_multi(file => 'somefile.gif')
4020     or die Imager->errstr;
4021
4022 Note that in some cases object methods are implemented in terms of
4023 class methods so a failing object method may set both.
4024
4025 =back
4026
4027 The C<Imager-E<gt>new> method is described in detail in
4028 L<Imager::ImageTypes>.
4029
4030 =head1 METHOD INDEX
4031
4032 Where to find information on methods for Imager class objects.
4033
4034 addcolors() -  L<Imager::ImageTypes/addcolors>
4035
4036 addtag() -  L<Imager::ImageTypes/addtag> - add image tags
4037
4038 align_string() - L<Imager::Draw/align_string>
4039
4040 arc() - L<Imager::Draw/arc>
4041
4042 bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
4043 image
4044
4045 box() - L<Imager::Draw/box>
4046
4047 circle() - L<Imager::Draw/circle>
4048
4049 colorcount() - L<Imager::Draw/colorcount>
4050
4051 combines() - L<Imager::Draw/combines>
4052
4053 compose() - L<Imager::Transformations/compose>
4054
4055 convert() - L<Imager::Transformations/"Color transformations"> -
4056 transform the color space
4057
4058 copy() - L<Imager::Transformations/copy>
4059
4060 crop() - L<Imager::Transformations/crop> - extract part of an image
4061
4062 def_guess_type() - L<Imager::Files/def_guess_type>
4063
4064 deltag() -  L<Imager::ImageTypes/deltag> - delete image tags
4065
4066 difference() - L<Imager::Filters/"Image Difference">
4067
4068 errstr() - L<"Basic Overview">
4069
4070 filter() - L<Imager::Filters>
4071
4072 findcolor() - L<Imager::ImageTypes/findcolor> - search the image palette, if it
4073 has one
4074
4075 flip() - L<Imager::Transformations/flip>
4076
4077 flood_fill() - L<Imager::Draw/flood_fill>
4078
4079 getchannels() -  L<Imager::ImageTypes/getchannels>
4080
4081 getcolorcount() -  L<Imager::ImageTypes/getcolorcount>
4082
4083 getcolors() - L<Imager::ImageTypes/getcolors> - get colors from the image
4084 palette, if it has one
4085
4086 getcolorusage() - L<Imager::ImageTypes/getcolorusage>
4087
4088 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash>
4089
4090 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
4091
4092 getheight() - L<Imager::ImageTypes/getwidth>
4093
4094 getmask() - L<Imager::ImageTypes/getmask>
4095
4096 getpixel() - L<Imager::Draw/getpixel>
4097
4098 getsamples() - L<Imager::Draw/getsamples>
4099
4100 getscanline() - L<Imager::Draw/getscanline>
4101
4102 getwidth() - L<Imager::ImageTypes/getwidth>
4103
4104 img_set() - L<Imager::ImageTypes/img_set>
4105
4106 init() - L<Imager::ImageTypes/init>
4107
4108 is_bilevel() - L<Imager::ImageTypes/is_bilevel>
4109
4110 line() - L<Imager::Draw/line>
4111
4112 load_plugin() - L<Imager::Filters/load_plugin>
4113
4114 map() - L<Imager::Transformations/"Color Mappings"> - remap color
4115 channel values
4116
4117 masked() -  L<Imager::ImageTypes/masked> - make a masked image
4118
4119 matrix_transform() - L<Imager::Engines/matrix_transform>
4120
4121 maxcolors() - L<Imager::ImageTypes/maxcolors>
4122
4123 NC() - L<Imager::Handy/NC>
4124
4125 NCF() - L<Imager::Handy/NCF>
4126
4127 new() - L<Imager::ImageTypes/new>
4128
4129 newcolor() - L<Imager::Handy/newcolor>
4130
4131 newcolour() - L<Imager::Handy/newcolour>
4132
4133 newfont() - L<Imager::Handy/newfont>
4134
4135 NF() - L<Imager::Handy/NF>
4136
4137 open() - L<Imager::Files> - an alias for read()
4138
4139 parseiptc() - L<Imager::Files/parseiptc> - parse IPTC data from a JPEG
4140 image
4141
4142 paste() - L<Imager::Transformations/paste> - draw an image onto an image
4143
4144 polygon() - L<Imager::Draw/polygon>
4145
4146 polyline() - L<Imager::Draw/polyline>
4147
4148 read() - L<Imager::Files> - read a single image from an image file
4149
4150 read_multi() - L<Imager::Files> - read multiple images from an image
4151 file
4152
4153 read_types() - L<Imager::Files/read_types> - list image types Imager
4154 can read.
4155
4156 register_filter() - L<Imager::Filters/register_filter>
4157
4158 register_reader() - L<Imager::Filters/register_reader>
4159
4160 register_writer() - L<Imager::Filters/register_writer>
4161
4162 rotate() - L<Imager::Transformations/rotate>
4163
4164 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
4165 image and use the alpha channel
4166
4167 scale() - L<Imager::Transformations/scale>
4168
4169 scale_calculate() - L<Imager::Transformations/scale_calculate>
4170
4171 scaleX() - L<Imager::Transformations/scaleX>
4172
4173 scaleY() - L<Imager::Transformations/scaleY>
4174
4175 setcolors() - L<Imager::ImageTypes/setcolors> - set palette colors in
4176 a paletted image
4177
4178 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
4179
4180 setmask() - L<Imager::ImageTypes/setmask>
4181
4182 setpixel() - L<Imager::Draw/setpixel>
4183
4184 setsamples() - L<Imager::Draw/setsamples>
4185
4186 setscanline() - L<Imager::Draw/setscanline>
4187
4188 settag() - L<Imager::ImageTypes/settag>
4189
4190 string() - L<Imager::Draw/string> - draw text on an image
4191
4192 tags() -  L<Imager::ImageTypes/tags> - fetch image tags
4193
4194 to_paletted() -  L<Imager::ImageTypes/to_paletted>
4195
4196 to_rgb16() - L<Imager::ImageTypes/to_rgb16>
4197
4198 to_rgb8() - L<Imager::ImageTypes/to_rgb8>
4199
4200 transform() - L<Imager::Engines/"transform">
4201
4202 transform2() - L<Imager::Engines/"transform2">
4203
4204 type() -  L<Imager::ImageTypes/type> - type of image (direct vs paletted)
4205
4206 unload_plugin() - L<Imager::Filters/unload_plugin>
4207
4208 virtual() - L<Imager::ImageTypes/virtual> - whether the image has it's own
4209 data
4210
4211 write() - L<Imager::Files> - write an image to a file
4212
4213 write_multi() - L<Imager::Files> - write multiple image to an image
4214 file.
4215
4216 write_types() - L<Imager::Files/read_types> - list image types Imager
4217 can write.
4218
4219 =head1 CONCEPT INDEX
4220
4221 animated GIF - L<Imager::Files/"Writing an animated GIF">
4222
4223 aspect ratio - L<Imager::ImageTypes/i_xres>,
4224 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
4225
4226 blend - alpha blending one image onto another
4227 L<Imager::Transformations/rubthrough>
4228
4229 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
4230
4231 boxes, drawing - L<Imager::Draw/box>
4232
4233 changes between image - L<Imager::Filter/"Image Difference">
4234
4235 color - L<Imager::Color>
4236
4237 color names - L<Imager::Color>, L<Imager::Color::Table>
4238
4239 combine modes - L<Imager::Fill/combine>
4240
4241 compare images - L<Imager::Filter/"Image Difference">
4242
4243 contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
4244
4245 convolution - L<Imager::Filter/conv>
4246
4247 cropping - L<Imager::Transformations/crop>
4248
4249 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4250
4251 C<diff> images - L<Imager::Filter/"Image Difference">
4252
4253 dpi - L<Imager::ImageTypes/i_xres>,
4254 L<Imager::Cookbook/"Image spatial resolution">
4255
4256 drawing boxes - L<Imager::Draw/box>
4257
4258 drawing lines - L<Imager::Draw/line>
4259
4260 drawing text - L<Imager::Draw/string>, L<Imager::Draw/align_string>
4261
4262 error message - L<"Basic Overview">
4263
4264 files, font - L<Imager::Font>
4265
4266 files, image - L<Imager::Files>
4267
4268 filling, types of fill - L<Imager::Fill>
4269
4270 filling, boxes - L<Imager::Draw/box>
4271
4272 filling, flood fill - L<Imager::Draw/flood_fill>
4273
4274 flood fill - L<Imager::Draw/flood_fill>
4275
4276 fonts - L<Imager::Font>
4277
4278 fonts, drawing with - L<Imager::Draw/string>,
4279 L<Imager::Draw/align_string>, L<Imager::Font::Wrap>
4280
4281 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4282
4283 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4284
4285 fountain fill - L<Imager::Fill/"Fountain fills">,
4286 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4287 L<Imager::Filters/gradgen>
4288
4289 GIF files - L<Imager::Files/"GIF">
4290
4291 GIF files, animated - L<Imager::File/"Writing an animated GIF">
4292
4293 gradient fill - L<Imager::Fill/"Fountain fills">,
4294 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4295 L<Imager::Filters/gradgen>
4296
4297 grayscale, convert image to - L<Imager::Transformations/convert>
4298
4299 guassian blur - L<Imager::Filter/guassian>
4300
4301 hatch fills - L<Imager::Fill/"Hatched fills">
4302
4303 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4304
4305 invert image - L<Imager::Filter/hardinvert>
4306
4307 JPEG - L<Imager::Files/"JPEG">
4308
4309 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4310
4311 lines, drawing - L<Imager::Draw/line>
4312
4313 matrix - L<Imager::Matrix2d>,
4314 L<Imager::Transformations/"Matrix Transformations">,
4315 L<Imager::Font/transform>
4316
4317 metadata, image - L<Imager::ImageTypes/"Tags">
4318
4319 mosaic - L<Imager::Filter/mosaic>
4320
4321 noise, filter - L<Imager::Filter/noise>
4322
4323 noise, rendered - L<Imager::Filter/turbnoise>,
4324 L<Imager::Filter/radnoise>
4325
4326 paste - L<Imager::Transformations/paste>,
4327 L<Imager::Transformations/rubthrough>
4328
4329 pseudo-color image - L<Imager::ImageTypes/to_paletted>,
4330 L<Imager::ImageTypes/new>
4331
4332 posterize - L<Imager::Filter/postlevels>
4333
4334 png files - L<Imager::Files>, L<Imager::Files/"PNG">
4335
4336 pnm - L<Imager::Files/"PNM (Portable aNy Map)">
4337
4338 rectangles, drawing - L<Imager::Draw/box>
4339
4340 resizing an image - L<Imager::Transformations/scale>,
4341 L<Imager::Transformations/crop>
4342
4343 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4344
4345 saving an image - L<Imager::Files>
4346
4347 scaling - L<Imager::Transformations/scale>
4348
4349 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4350
4351 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4352
4353 size, image - L<Imager::ImageTypes/getwidth>,
4354 L<Imager::ImageTypes/getheight>
4355
4356 size, text - L<Imager::Font/bounding_box>
4357
4358 tags, image metadata - L<Imager::ImageTypes/"Tags">
4359
4360 text, drawing - L<Imager::Draw/string>, L<Imager::Draw/align_string>,
4361 L<Imager::Font::Wrap>
4362
4363 text, wrapping text in an area - L<Imager::Font::Wrap>
4364
4365 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4366
4367 tiles, color - L<Imager::Filter/mosaic>
4368
4369 unsharp mask - L<Imager::Filter/unsharpmask>
4370
4371 watermark - L<Imager::Filter/watermark>
4372
4373 writing an image to a file - L<Imager::Files>
4374
4375 =head1 SUPPORT
4376
4377 The best place to get help with Imager is the mailing list.
4378
4379 To subscribe send a message with C<subscribe> in the body to:
4380
4381    imager-devel+request@molar.is
4382
4383 or use the form at:
4384
4385 =over
4386
4387 L<http://www.molar.is/en/lists/imager-devel/>
4388
4389 =back
4390
4391 where you can also find the mailing list archive.
4392
4393 You can report bugs by pointing your browser at:
4394
4395 =over
4396
4397 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4398
4399 =back
4400
4401 or by sending an email to:
4402
4403 =over
4404
4405 bug-Imager@rt.cpan.org
4406
4407 =back
4408
4409 Please remember to include the versions of Imager, perl, supporting
4410 libraries, and any relevant code.  If you have specific images that
4411 cause the problems, please include those too.
4412
4413 If you don't want to publish your email address on a mailing list you
4414 can use CPAN::Forum:
4415
4416   http://www.cpanforum.com/dist/Imager
4417
4418 You will need to register to post.
4419
4420 =head1 CONTRIBUTING TO IMAGER
4421
4422 =head2 Feedback
4423
4424 I like feedback.
4425
4426 If you like or dislike Imager, you can add a public review of Imager
4427 at CPAN Ratings:
4428
4429   http://cpanratings.perl.org/dist/Imager
4430
4431 This requires a Bitcard Account (http://www.bitcard.org).
4432
4433 You can also send email to the maintainer below.
4434
4435 If you send me a bug report via email, it will be copied to RT.
4436
4437 =head2 Patches
4438
4439 I accept patches, preferably against the main branch in subversion.
4440 You should include an explanation of the reason for why the patch is
4441 needed or useful.
4442
4443 Your patch should include regression tests where possible, otherwise
4444 it will be delayed until I get a chance to write them.
4445
4446 =head1 AUTHOR
4447
4448 Tony Cook <tony@imager.perl.org> is the current maintainer for Imager.
4449
4450 Arnar M. Hrafnkelsson is the original author of Imager.
4451
4452 Many others have contributed to Imager, please see the README for a
4453 complete list.
4454
4455 =head1 SEE ALSO
4456
4457 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4458 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4459 L<Imager::Font>(3), L<Imager::Transformations>(3),
4460 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4461 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4462
4463 L<http://imager.perl.org/>
4464
4465 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4466
4467 Other perl imaging modules include:
4468
4469 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3).
4470
4471 =cut