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