Imager.pm

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