Imager.pm

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