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     $self->{ERRSTR} = _error_as_msg();
3585     return undef;
3586   }
3587   return $new;
3588 }
3589
3590 # combine channels from multiple input images, a class method
3591 sub combine {
3592   my ($class, %opts) = @_;
3593
3594   my $src = delete $opts{src};
3595   unless ($src) {
3596     $class->_set_error("src parameter missing");
3597     return;
3598   }
3599   my @imgs;
3600   my $index = 0;
3601   for my $img (@$src) {
3602     unless (eval { $img->isa("Imager") }) {
3603       $class->_set_error("src must contain image objects");
3604       return;
3605     }
3606     unless ($img->{IMG}) {
3607       $class->_set_error("empty input image");
3608       return;
3609     }
3610     push @imgs, $img->{IMG};
3611   }
3612   my $result;
3613   if (my $channels = delete $opts{channels}) {
3614     $result = i_combine(\@imgs, $channels);
3615   }
3616   else {
3617     $result = i_combine(\@imgs);
3618   }
3619   unless ($result) {
3620     $class->_set_error($class->_error_as_msg);
3621     return;
3622   }
3623
3624   my $img = $class->new;
3625   $img->{IMG} = $result;
3626
3627   return $img;
3628 }
3629
3630
3631 # general function to map an image through lookup tables
3632
3633 sub map {
3634   my ($self, %opts) = @_;
3635   my @chlist = qw( red green blue alpha );
3636
3637   if (!exists($opts{'maps'})) {
3638     # make maps from channel maps
3639     my $chnum;
3640     for $chnum (0..$#chlist) {
3641       if (exists $opts{$chlist[$chnum]}) {
3642         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3643       } elsif (exists $opts{'all'}) {
3644         $opts{'maps'}[$chnum] = $opts{'all'};
3645       }
3646     }
3647   }
3648   if ($opts{'maps'} and $self->{IMG}) {
3649     i_map($self->{IMG}, $opts{'maps'} );
3650   }
3651   return $self;
3652 }
3653
3654 sub difference {
3655   my ($self, %opts) = @_;
3656
3657   defined $opts{mindist} or $opts{mindist} = 0;
3658
3659   defined $opts{other}
3660     or return $self->_set_error("No 'other' parameter supplied");
3661   defined $opts{other}{IMG}
3662     or return $self->_set_error("No image data in 'other' image");
3663
3664   $self->{IMG}
3665     or return $self->_set_error("No image data");
3666
3667   my $result = Imager->new;
3668   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3669                                 $opts{mindist})
3670     or return $self->_set_error($self->_error_as_msg());
3671
3672   return $result;
3673 }
3674
3675 # destructive border - image is shrunk by one pixel all around
3676
3677 sub border {
3678   my ($self,%opts)=@_;
3679   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3680   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3681 }
3682
3683
3684 # Get the width of an image
3685
3686 sub getwidth {
3687   my $self = shift;
3688
3689   if (my $raw = $self->{IMG}) {
3690     return i_img_get_width($raw);
3691   }
3692   else {
3693     $self->{ERRSTR} = 'image is empty'; return undef;
3694   }
3695 }
3696
3697 # Get the height of an image
3698
3699 sub getheight {
3700   my $self = shift;
3701
3702   if (my $raw = $self->{IMG}) {
3703     return i_img_get_height($raw);
3704   }
3705   else {
3706     $self->{ERRSTR} = 'image is empty'; return undef;
3707   }
3708 }
3709
3710 # Get number of channels in an image
3711
3712 sub getchannels {
3713   my $self = shift;
3714   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3715   return i_img_getchannels($self->{IMG});
3716 }
3717
3718 # Get channel mask
3719
3720 sub getmask {
3721   my $self = shift;
3722   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3723   return i_img_getmask($self->{IMG});
3724 }
3725
3726 # Set channel mask
3727
3728 sub setmask {
3729   my $self = shift;
3730   my %opts = @_;
3731   if (!defined($self->{IMG})) {
3732     $self->{ERRSTR} = 'image is empty';
3733     return undef;
3734   }
3735   unless (defined $opts{mask}) {
3736     $self->_set_error("mask parameter required");
3737     return;
3738   }
3739   i_img_setmask( $self->{IMG} , $opts{mask} );
3740
3741   1;
3742 }
3743
3744 # Get number of colors in an image
3745
3746 sub getcolorcount {
3747   my $self=shift;
3748   my %opts=('maxcolors'=>2**30,@_);
3749   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3750   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3751   return ($rc==-1? undef : $rc);
3752 }
3753
3754 # Returns a reference to a hash. The keys are colour named (packed) and the
3755 # values are the number of pixels in this colour.
3756 sub getcolorusagehash {
3757   my $self = shift;
3758
3759   my %opts = ( maxcolors => 2**30, @_ );
3760   my $max_colors = $opts{maxcolors};
3761   unless (defined $max_colors && $max_colors > 0) {
3762     $self->_set_error('maxcolors must be a positive integer');
3763     return;
3764   }
3765
3766   unless (defined $self->{IMG}) {
3767     $self->_set_error('empty input image');
3768     return;
3769   }
3770
3771   my $channels= $self->getchannels;
3772   # We don't want to look at the alpha channel, because some gifs using it
3773   # doesn't define it for every colour (but only for some)
3774   $channels -= 1 if $channels == 2 or $channels == 4;
3775   my %color_use;
3776   my $height = $self->getheight;
3777   for my $y (0 .. $height - 1) {
3778     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3779     while (length $colors) {
3780       $color_use{ substr($colors, 0, $channels, '') }++;
3781     }
3782     keys %color_use > $max_colors
3783       and return;
3784   }
3785   return \%color_use;
3786 }
3787
3788 # This will return a ordered array of the colour usage. Kind of the sorted
3789 # version of the values of the hash returned by getcolorusagehash.
3790 # You might want to add safety checks and change the names, etc...
3791 sub getcolorusage {
3792   my $self = shift;
3793
3794   my %opts = ( maxcolors => 2**30, @_ );
3795   my $max_colors = $opts{maxcolors};
3796   unless (defined $max_colors && $max_colors > 0) {
3797     $self->_set_error('maxcolors must be a positive integer');
3798     return;
3799   }
3800
3801   unless (defined $self->{IMG}) {
3802     $self->_set_error('empty input image');
3803     return undef;
3804   }
3805
3806   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3807 }
3808
3809 # draw string to an image
3810
3811 sub string {
3812   my $self = shift;
3813   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3814
3815   my %input=('x'=>0, 'y'=>0, @_);
3816   defined($input{string}) or $input{string} = $input{text};
3817
3818   unless(defined $input{string}) {
3819     $self->{ERRSTR}="missing required parameter 'string'";
3820     return;
3821   }
3822
3823   unless($input{font}) {
3824     $self->{ERRSTR}="missing required parameter 'font'";
3825     return;
3826   }
3827
3828   unless ($input{font}->draw(image=>$self, %input)) {
3829     return;
3830   }
3831
3832   return $self;
3833 }
3834
3835 sub align_string {
3836   my $self = shift;
3837
3838   my $img;
3839   if (ref $self) {
3840     unless ($self->{IMG}) {
3841       $self->{ERRSTR}='empty input image';
3842       return;
3843     }
3844     $img = $self;
3845   }
3846   else {
3847     $img = undef;
3848   }
3849
3850   my %input=('x'=>0, 'y'=>0, @_);
3851   defined $input{string}
3852     or $input{string} = $input{text};
3853
3854   unless(exists $input{string}) {
3855     $self->_set_error("missing required parameter 'string'");
3856     return;
3857   }
3858
3859   unless($input{font}) {
3860     $self->_set_error("missing required parameter 'font'");
3861     return;
3862   }
3863
3864   my @result;
3865   unless (@result = $input{font}->align(image=>$img, %input)) {
3866     return;
3867   }
3868
3869   return wantarray ? @result : $result[0];
3870 }
3871
3872 my @file_limit_names = qw/width height bytes/;
3873
3874 sub set_file_limits {
3875   shift;
3876
3877   my %opts = @_;
3878   my %values;
3879
3880   if ($opts{reset}) {
3881     @values{@file_limit_names} = (0) x @file_limit_names;
3882   }
3883   else {
3884     @values{@file_limit_names} = i_get_image_file_limits();
3885   }
3886
3887   for my $key (keys %values) {
3888     defined $opts{$key} and $values{$key} = $opts{$key};
3889   }
3890
3891   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3892 }
3893
3894 sub get_file_limits {
3895   i_get_image_file_limits();
3896 }
3897
3898 my @check_args = qw(width height channels sample_size);
3899
3900 sub check_file_limits {
3901   my $class = shift;
3902
3903   my %opts =
3904     (
3905      channels => 3,
3906      sample_size => 1,
3907      @_,
3908     );
3909
3910   if ($opts{sample_size} && $opts{sample_size} eq 'float') {
3911     $opts{sample_size} = length(pack("d", 0));
3912   }
3913
3914   for my $name (@check_args) {
3915     unless (defined $opts{$name}) {
3916       $class->_set_error("check_file_limits: $name must be defined");
3917       return;
3918     }
3919     unless ($opts{$name} == int($opts{$name})) {
3920       $class->_set_error("check_file_limits: $name must be a positive integer");
3921       return;
3922     }
3923   }
3924
3925   my $result = i_int_check_image_file_limits(@opts{@check_args});
3926   unless ($result) {
3927     $class->_set_error($class->_error_as_msg());
3928   }
3929
3930   return $result;
3931 }
3932
3933 # Shortcuts that can be exported
3934
3935 sub newcolor { Imager::Color->new(@_); }
3936 sub newfont  { Imager::Font->new(@_); }
3937 sub NCF {
3938   require Imager::Color::Float;
3939   return Imager::Color::Float->new(@_);
3940 }
3941
3942 *NC=*newcolour=*newcolor;
3943 *NF=*newfont;
3944
3945 *open=\&read;
3946 *circle=\&arc;
3947
3948
3949 #### Utility routines
3950
3951 sub errstr {
3952   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3953 }
3954
3955 sub _set_error {
3956   my ($self, $msg) = @_;
3957
3958   if (ref $self) {
3959     $self->{ERRSTR} = $msg;
3960   }
3961   else {
3962     $ERRSTR = $msg;
3963   }
3964   return;
3965 }
3966
3967 # Default guess for the type of an image from extension
3968
3969 my @simple_types = qw(png tga gif raw ico cur xpm mng jng ilbm pcx psd eps);
3970
3971 my %ext_types =
3972   (
3973    ( map { $_ => $_ } @simple_types ),
3974    tiff => "tiff",
3975    tif => "tiff",
3976    pbm => "pnm",
3977    pgm => "pnm",
3978    ppm => "pnm",
3979    pnm => "pnm", # technically wrong, but historically it works in Imager
3980    jpeg => "jpeg",
3981    jpg => "jpeg",
3982    bmp => "bmp",
3983    dib => "bmp",
3984    rgb => "sgi",
3985    bw => "sgi",
3986    sgi => "sgi",
3987    fit => "fits",
3988    fits => "fits",
3989    rle => "utah",
3990   );
3991
3992 sub def_guess_type {
3993   my $name=lc(shift);
3994
3995   my ($ext) = $name =~ /\.([^.]+)$/
3996     or return;
3997
3998   my $type = $ext_types{$ext}
3999     or return;
4000
4001   return $type;
4002 }
4003
4004 sub combines {
4005   return @combine_types;
4006 }
4007
4008 # get the minimum of a list
4009
4010 sub _min {
4011   my $mx=shift;
4012   for(@_) { if ($_<$mx) { $mx=$_; }}
4013   return $mx;
4014 }
4015
4016 # get the maximum of a list
4017
4018 sub _max {
4019   my $mx=shift;
4020   for(@_) { if ($_>$mx) { $mx=$_; }}
4021   return $mx;
4022 }
4023
4024 # string stuff for iptc headers
4025
4026 sub _clean {
4027   my($str)=$_[0];
4028   $str = substr($str,3);
4029   $str =~ s/[\n\r]//g;
4030   $str =~ s/\s+/ /g;
4031   $str =~ s/^\s//;
4032   $str =~ s/\s$//;
4033   return $str;
4034 }
4035
4036 # A little hack to parse iptc headers.
4037
4038 sub parseiptc {
4039   my $self=shift;
4040   my(@sar,$item,@ar);
4041   my($caption,$photogr,$headln,$credit);
4042
4043   my $str=$self->{IPTCRAW};
4044
4045   defined $str
4046     or return;
4047
4048   @ar=split(/8BIM/,$str);
4049
4050   my $i=0;
4051   foreach (@ar) {
4052     if (/^\004\004/) {
4053       @sar=split(/\034\002/);
4054       foreach $item (@sar) {
4055         if ($item =~ m/^x/) {
4056           $caption = _clean($item);
4057           $i++;
4058         }
4059         if ($item =~ m/^P/) {
4060           $photogr = _clean($item);
4061           $i++;
4062         }
4063         if ($item =~ m/^i/) {
4064           $headln = _clean($item);
4065           $i++;
4066         }
4067         if ($item =~ m/^n/) {
4068           $credit = _clean($item);
4069           $i++;
4070         }
4071       }
4072     }
4073   }
4074   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
4075 }
4076
4077 sub Inline {
4078   my ($lang) = @_;
4079
4080   $lang eq 'C'
4081     or die "Only C language supported";
4082
4083   require Imager::ExtUtils;
4084   return Imager::ExtUtils->inline_config;
4085 }
4086
4087 # threads shouldn't try to close raw Imager objects
4088 sub Imager::ImgRaw::CLONE_SKIP { 1 }
4089
4090 sub preload {
4091   # this serves two purposes:
4092   # - a class method to load the file support modules included with Imager
4093   #   (or were included, once the library dependent modules are split out)
4094   # - something for Module::ScanDeps to analyze
4095   # https://rt.cpan.org/Ticket/Display.html?id=6566
4096   local $@;
4097   eval { require Imager::File::GIF };
4098   eval { require Imager::File::JPEG };
4099   eval { require Imager::File::PNG };
4100   eval { require Imager::File::SGI };
4101   eval { require Imager::File::TIFF };
4102   eval { require Imager::File::ICO };
4103   eval { require Imager::Font::W32 };
4104   eval { require Imager::Font::FT2 };
4105   eval { require Imager::Font::T1 };
4106 }
4107
4108 # backward compatibility for %formats
4109 package Imager::FORMATS;
4110 use strict;
4111 use constant IX_FORMATS => 0;
4112 use constant IX_LIST => 1;
4113 use constant IX_INDEX => 2;
4114 use constant IX_CLASSES => 3;
4115
4116 sub TIEHASH {
4117   my ($class, $formats, $classes) = @_;
4118
4119   return bless [ $formats, [ ], 0, $classes ], $class;
4120 }
4121
4122 sub _check {
4123   my ($self, $key) = @_;
4124
4125   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4126   my $value;
4127   my $error;
4128   my $loaded = Imager::_load_file($file, \$error);
4129   if ($loaded) {
4130     $value = 1;
4131   }
4132   else {
4133     if ($error =~ /^Can't locate /) {
4134       $error = "Can't locate $file";
4135     }
4136     $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
4137     $value = undef;
4138   }
4139   $self->[IX_FORMATS]{$key} = $value;
4140
4141   return $value;
4142 }
4143
4144 sub FETCH {
4145   my ($self, $key) = @_;
4146
4147   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4148
4149   $self->[IX_CLASSES]{$key} or return undef;
4150
4151   return $self->_check($key);
4152 }
4153
4154 sub STORE {
4155   die "%Imager::formats is not user monifiable";
4156 }
4157
4158 sub DELETE {
4159   die "%Imager::formats is not user monifiable";
4160 }
4161
4162 sub CLEAR {
4163   die "%Imager::formats is not user monifiable";
4164 }
4165
4166 sub EXISTS {
4167   my ($self, $key) = @_;
4168
4169   if (exists $self->[IX_FORMATS]{$key}) {
4170     my $value = $self->[IX_FORMATS]{$key}
4171       or return;
4172     return 1;
4173   }
4174
4175   $self->_check($key) or return 1==0;
4176
4177   return 1==1;
4178 }
4179
4180 sub FIRSTKEY {
4181   my ($self) = @_;
4182
4183   unless (@{$self->[IX_LIST]}) {
4184     # full populate it
4185     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4186       keys %{$self->[IX_FORMATS]};
4187
4188     for my $key (keys %{$self->[IX_CLASSES]}) {
4189       $self->[IX_FORMATS]{$key} and next;
4190       $self->_check($key)
4191         and push @{$self->[IX_LIST]}, $key;
4192     }
4193   }
4194
4195   @{$self->[IX_LIST]} or return;
4196   $self->[IX_INDEX] = 1;
4197   return $self->[IX_LIST][0];
4198 }
4199
4200 sub NEXTKEY {
4201   my ($self) = @_;
4202
4203   $self->[IX_INDEX] < @{$self->[IX_LIST]}
4204     or return;
4205
4206   return $self->[IX_LIST][$self->[IX_INDEX]++];
4207 }
4208
4209 sub SCALAR {
4210   my ($self) = @_;
4211
4212   return scalar @{$self->[IX_LIST]};
4213 }
4214
4215 1;
4216 __END__
4217 # Below is the stub of documentation for your module. You better edit it!
4218
4219 =head1 NAME
4220
4221 Imager - Perl extension for Generating 24 bit Images
4222
4223 =head1 SYNOPSIS
4224
4225   # Thumbnail example
4226
4227   #!/usr/bin/perl -w
4228   use strict;
4229   use Imager;
4230
4231   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
4232   my $file = shift;
4233
4234   my $format;
4235
4236   # see Imager::Files for information on the read() method
4237   my $img = Imager->new(file=>$file)
4238     or die Imager->errstr();
4239
4240   $file =~ s/\.[^.]*$//;
4241
4242   # Create smaller version
4243   # documented in Imager::Transformations
4244   my $thumb = $img->scale(scalefactor=>.3);
4245
4246   # Autostretch individual channels
4247   $thumb->filter(type=>'autolevels');
4248
4249   # try to save in one of these formats
4250   SAVE:
4251
4252   for $format ( qw( png gif jpeg tiff ppm ) ) {
4253     # Check if given format is supported
4254     if ($Imager::formats{$format}) {
4255       $file.="_low.$format";
4256       print "Storing image as: $file\n";
4257       # documented in Imager::Files
4258       $thumb->write(file=>$file) or
4259         die $thumb->errstr;
4260       last SAVE;
4261     }
4262   }
4263
4264 =head1 DESCRIPTION
4265
4266 Imager is a module for creating and altering images.  It can read and
4267 write various image formats, draw primitive shapes like lines,and
4268 polygons, blend multiple images together in various ways, scale, crop,
4269 render text and more.
4270
4271 =head2 Overview of documentation
4272
4273 =over
4274
4275 =item *
4276
4277 Imager - This document - Synopsis, Example, Table of Contents and
4278 Overview.
4279
4280 =item *
4281
4282 L<Imager::Tutorial> - a brief introduction to Imager.
4283
4284 =item *
4285
4286 L<Imager::Cookbook> - how to do various things with Imager.
4287
4288 =item *
4289
4290 L<Imager::ImageTypes> - Basics of constructing image objects with
4291 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4292 8/16/double bits/channel, color maps, channel masks, image tags, color
4293 quantization.  Also discusses basic image information methods.
4294
4295 =item *
4296
4297 L<Imager::Files> - IO interaction, reading/writing images, format
4298 specific tags.
4299
4300 =item *
4301
4302 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4303 flood fill.
4304
4305 =item *
4306
4307 L<Imager::Color> - Color specification.
4308
4309 =item *
4310
4311 L<Imager::Fill> - Fill pattern specification.
4312
4313 =item *
4314
4315 L<Imager::Font> - General font rendering, bounding boxes and font
4316 metrics.
4317
4318 =item *
4319
4320 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4321 blending, pasting, convert and map.
4322
4323 =item *
4324
4325 L<Imager::Engines> - Programmable transformations through
4326 C<transform()>, C<transform2()> and C<matrix_transform()>.
4327
4328 =item *
4329
4330 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4331 filter plug-ins.
4332
4333 =item *
4334
4335 L<Imager::Expr> - Expressions for evaluation engine used by
4336 transform2().
4337
4338 =item *
4339
4340 L<Imager::Matrix2d> - Helper class for affine transformations.
4341
4342 =item *
4343
4344 L<Imager::Fountain> - Helper for making gradient profiles.
4345
4346 =item *
4347
4348 L<Imager::API> - using Imager's C API
4349
4350 =item *
4351
4352 L<Imager::APIRef> - API function reference
4353
4354 =item *
4355
4356 L<Imager::Inline> - using Imager's C API from Inline::C
4357
4358 =item *
4359
4360 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4361
4362 =item *
4363
4364 L<Imager::Security> - brief security notes.
4365
4366 =back
4367
4368 =head2 Basic Overview
4369
4370 An Image object is created with C<$img = Imager-E<gt>new()>.
4371 Examples:
4372
4373   $img=Imager->new();                         # create empty image
4374   $img->read(file=>'lena.png',type=>'png') or # read image from file
4375      die $img->errstr();                      # give an explanation
4376                                               # if something failed
4377
4378 or if you want to create an empty image:
4379
4380   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4381
4382 This example creates a completely black image of width 400 and height
4383 300 and 4 channels.
4384
4385 =head1 ERROR HANDLING
4386
4387 In general a method will return false when it fails, if it does use
4388 the C<errstr()> method to find out why:
4389
4390 =over
4391
4392 =item errstr()
4393
4394 Returns the last error message in that context.
4395
4396 If the last error you received was from calling an object method, such
4397 as read, call errstr() as an object method to find out why:
4398
4399   my $image = Imager->new;
4400   $image->read(file => 'somefile.gif')
4401      or die $image->errstr;
4402
4403 If it was a class method then call errstr() as a class method:
4404
4405   my @imgs = Imager->read_multi(file => 'somefile.gif')
4406     or die Imager->errstr;
4407
4408 Note that in some cases object methods are implemented in terms of
4409 class methods so a failing object method may set both.
4410
4411 =back
4412
4413 The C<Imager-E<gt>new> method is described in detail in
4414 L<Imager::ImageTypes>.
4415
4416 =head1 METHOD INDEX
4417
4418 Where to find information on methods for Imager class objects.
4419
4420 addcolors() - L<Imager::ImageTypes/addcolors()> - add colors to a
4421 paletted image
4422
4423 addtag() -  L<Imager::ImageTypes/addtag()> - add image tags
4424
4425 align_string() - L<Imager::Draw/align_string()> - draw text aligned on a
4426 point
4427
4428 arc() - L<Imager::Draw/arc()> - draw a filled arc
4429
4430 bits() - L<Imager::ImageTypes/bits()> - number of bits per sample for the
4431 image
4432
4433 box() - L<Imager::Draw/box()> - draw a filled or outline box.
4434
4435 check_file_limits() - L<Imager::Files/check_file_limits()>
4436
4437 circle() - L<Imager::Draw/circle()> - draw a filled circle
4438
4439 close_log() - L<Imager::ImageTypes/close_log()> - close the Imager
4440 debugging log.
4441
4442 colorcount() - L<Imager::ImageTypes/colorcount()> - the number of
4443 colors in an image's palette (paletted images only)
4444
4445 combine() - L<Imager::Transformations/combine()> - combine channels
4446 from one or more images.
4447
4448 combines() - L<Imager::Draw/combines()> - return a list of the
4449 different combine type keywords
4450
4451 compose() - L<Imager::Transformations/compose()> - compose one image
4452 over another.
4453
4454 convert() - L<Imager::Transformations/convert()> - transform the color
4455 space
4456
4457 copy() - L<Imager::Transformations/copy()> - make a duplicate of an
4458 image
4459
4460 crop() - L<Imager::Transformations/crop()> - extract part of an image
4461
4462 def_guess_type() - L<Imager::Files/def_guess_type()> - default function
4463 used to guess the output file format based on the output file name
4464
4465 deltag() -  L<Imager::ImageTypes/deltag()> - delete image tags
4466
4467 difference() - L<Imager::Filters/difference()> - produce a difference
4468 images from two input images.
4469
4470 errstr() - L</errstr()> - the error from the last failed operation.
4471
4472 filter() - L<Imager::Filters/filter()> - image filtering
4473
4474 findcolor() - L<Imager::ImageTypes/findcolor()> - search the image
4475 palette, if it has one
4476
4477 flip() - L<Imager::Transformations/flip()> - flip an image, vertically,
4478 horizontally
4479
4480 flood_fill() - L<Imager::Draw/flood_fill()> - fill an enclosed or same
4481 color area
4482
4483 getchannels() - L<Imager::ImageTypes/getchannels()> - the number of
4484 samples per pixel for an image
4485
4486 getcolorcount() - L<Imager::ImageTypes/getcolorcount()> - the number of
4487 different colors used by an image (works for direct color images)
4488
4489 getcolors() - L<Imager::ImageTypes/getcolors()> - get colors from the image
4490 palette, if it has one
4491
4492 getcolorusage() - L<Imager::ImageTypes/getcolorusage()>
4493
4494 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash()>
4495
4496 get_file_limits() - L<Imager::Files/get_file_limits()>
4497
4498 getheight() - L<Imager::ImageTypes/getheight()> - height of the image in
4499 pixels
4500
4501 getmask() - L<Imager::ImageTypes/getmask()> - write mask for the image
4502
4503 getpixel() - L<Imager::Draw/getpixel()> - retrieve one or more pixel
4504 colors
4505
4506 getsamples() - L<Imager::Draw/getsamples()> - retrieve samples from a
4507 row or partial row of pixels.
4508
4509 getscanline() - L<Imager::Draw/getscanline()> - retrieve colors for a
4510 row or partial row of pixels.
4511
4512 getwidth() - L<Imager::ImageTypes/getwidth()> - width of the image in
4513 pixels.
4514
4515 img_set() - L<Imager::ImageTypes/img_set()> - re-use an Imager object
4516 for a new image.
4517
4518 init() - L<Imager::ImageTypes/init()>
4519
4520 is_bilevel() - L<Imager::ImageTypes/is_bilevel()> - returns whether
4521 image write functions should write the image in their bilevel (blank
4522 and white, no gray levels) format
4523
4524 is_logging() L<Imager::ImageTypes/is_logging()> - test if the debug
4525 log is active.
4526
4527 line() - L<Imager::Draw/line()> - draw an interval
4528
4529 load_plugin() - L<Imager::Filters/load_plugin()>
4530
4531 log() - L<Imager::ImageTypes/log()> - send a message to the debugging
4532 log.
4533
4534 make_palette() - L<Imager::ImageTypes/make_palette()> - produce a
4535 color palette from one or more input images.
4536
4537 map() - L<Imager::Transformations/map()> - remap color
4538 channel values
4539
4540 masked() -  L<Imager::ImageTypes/masked()> - make a masked image
4541
4542 matrix_transform() - L<Imager::Engines/matrix_transform()>
4543
4544 maxcolors() - L<Imager::ImageTypes/maxcolors()>
4545
4546 NC() - L<Imager::Handy/NC()>
4547
4548 NCF() - L<Imager::Handy/NCF()>
4549
4550 new() - L<Imager::ImageTypes/new()>
4551
4552 newcolor() - L<Imager::Handy/newcolor()>
4553
4554 newcolour() - L<Imager::Handy/newcolour()>
4555
4556 newfont() - L<Imager::Handy/newfont()>
4557
4558 NF() - L<Imager::Handy/NF()>
4559
4560 open() - L<Imager::Files/read()> - an alias for read()
4561
4562 open_log() - L<Imager::ImageTypes/open_log()> - open the debug log.
4563
4564 =for stopwords IPTC
4565
4566 parseiptc() - L<Imager::Files/parseiptc()> - parse IPTC data from a JPEG
4567 image
4568
4569 paste() - L<Imager::Transformations/paste()> - draw an image onto an
4570 image
4571
4572 polygon() - L<Imager::Draw/polygon()>
4573
4574 polyline() - L<Imager::Draw/polyline()>
4575
4576 preload() - L<Imager::Files/preload()>
4577
4578 read() - L<Imager::Files/read()> - read a single image from an image file
4579
4580 read_multi() - L<Imager::Files/read_multi()> - read multiple images from an image
4581 file
4582
4583 read_types() - L<Imager::Files/read_types()> - list image types Imager
4584 can read.
4585
4586 register_filter() - L<Imager::Filters/register_filter()>
4587
4588 register_reader() - L<Imager::Files/register_reader()>
4589
4590 register_writer() - L<Imager::Files/register_writer()>
4591
4592 rotate() - L<Imager::Transformations/rotate()>
4593
4594 rubthrough() - L<Imager::Transformations/rubthrough()> - draw an image
4595 onto an image and use the alpha channel
4596
4597 scale() - L<Imager::Transformations/scale()>
4598
4599 scale_calculate() - L<Imager::Transformations/scale_calculate()>
4600
4601 scaleX() - L<Imager::Transformations/scaleX()>
4602
4603 scaleY() - L<Imager::Transformations/scaleY()>
4604
4605 setcolors() - L<Imager::ImageTypes/setcolors()> - set palette colors
4606 in a paletted image
4607
4608 set_file_limits() - L<Imager::Files/set_file_limits()>
4609
4610 setmask() - L<Imager::ImageTypes/setmask()>
4611
4612 setpixel() - L<Imager::Draw/setpixel()>
4613
4614 setsamples() - L<Imager::Draw/setsamples()>
4615
4616 setscanline() - L<Imager::Draw/setscanline()>
4617
4618 settag() - L<Imager::ImageTypes/settag()>
4619
4620 string() - L<Imager::Draw/string()> - draw text on an image
4621
4622 tags() -  L<Imager::ImageTypes/tags()> - fetch image tags
4623
4624 to_paletted() -  L<Imager::ImageTypes/to_paletted()>
4625
4626 to_rgb16() - L<Imager::ImageTypes/to_rgb16()>
4627
4628 to_rgb8() - L<Imager::ImageTypes/to_rgb8()>
4629
4630 to_rgb_double() - L<Imager::ImageTypes/to_rgb_double()> - convert to
4631 double per sample image.
4632
4633 transform() - L<Imager::Engines/"transform()">
4634
4635 transform2() - L<Imager::Engines/"transform2()">
4636
4637 type() -  L<Imager::ImageTypes/type()> - type of image (direct vs paletted)
4638
4639 unload_plugin() - L<Imager::Filters/unload_plugin()>
4640
4641 virtual() - L<Imager::ImageTypes/virtual()> - whether the image has it's own
4642 data
4643
4644 write() - L<Imager::Files/write()> - write an image to a file
4645
4646 write_multi() - L<Imager::Files/write_multi()> - write multiple image to an image
4647 file.
4648
4649 write_types() - L<Imager::Files/read_types()> - list image types Imager
4650 can write.
4651
4652 =head1 CONCEPT INDEX
4653
4654 animated GIF - L<Imager::Files/"Writing an animated GIF">
4655
4656 aspect ratio - C<i_xres>, C<i_yres>, C<i_aspect_only> in
4657 L<Imager::ImageTypes/"Common Tags">.
4658
4659 blend - alpha blending one image onto another
4660 L<Imager::Transformations/rubthrough()>
4661
4662 blur - L<Imager::Filters/gaussian>, L<Imager::Filters/conv>
4663
4664 boxes, drawing - L<Imager::Draw/box()>
4665
4666 changes between image - L<Imager::Filters/"Image Difference">
4667
4668 channels, combine into one image - L<Imager::Transformations/combine()>
4669
4670 color - L<Imager::Color>
4671
4672 color names - L<Imager::Color>, L<Imager::Color::Table>
4673
4674 combine modes - L<Imager::Draw/"Combine Types">
4675
4676 compare images - L<Imager::Filters/"Image Difference">
4677
4678 contrast - L<Imager::Filters/contrast>, L<Imager::Filters/autolevels>
4679
4680 convolution - L<Imager::Filters/conv>
4681
4682 cropping - L<Imager::Transformations/crop()>
4683
4684 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4685
4686 C<diff> images - L<Imager::Filters/"Image Difference">
4687
4688 dpi - C<i_xres>, C<i_yres> in L<Imager::ImageTypes/"Common Tags">,
4689 L<Imager::Cookbook/"Image spatial resolution">
4690
4691 drawing boxes - L<Imager::Draw/box()>
4692
4693 drawing lines - L<Imager::Draw/line()>
4694
4695 drawing text - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>
4696
4697 error message - L</"ERROR HANDLING">
4698
4699 files, font - L<Imager::Font>
4700
4701 files, image - L<Imager::Files>
4702
4703 filling, types of fill - L<Imager::Fill>
4704
4705 filling, boxes - L<Imager::Draw/box()>
4706
4707 filling, flood fill - L<Imager::Draw/flood_fill()>
4708
4709 flood fill - L<Imager::Draw/flood_fill()>
4710
4711 fonts - L<Imager::Font>
4712
4713 fonts, drawing with - L<Imager::Draw/string()>,
4714 L<Imager::Draw/align_string()>, L<Imager::Font::Wrap>
4715
4716 fonts, metrics - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4717
4718 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4719
4720 fountain fill - L<Imager::Fill/"Fountain fills">,
4721 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4722 L<Imager::Filters/gradgen>
4723
4724 GIF files - L<Imager::Files/"GIF">
4725
4726 GIF files, animated - L<Imager::Files/"Writing an animated GIF">
4727
4728 gradient fill - L<Imager::Fill/"Fountain fills">,
4729 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4730 L<Imager::Filters/gradgen>
4731
4732 gray scale, convert image to - L<Imager::Transformations/convert()>
4733
4734 gaussian blur - L<Imager::Filters/gaussian>
4735
4736 hatch fills - L<Imager::Fill/"Hatched fills">
4737
4738 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4739
4740 invert image - L<Imager::Filters/hardinvert>,
4741 L<Imager::Filters/hardinvertall>
4742
4743 JPEG - L<Imager::Files/"JPEG">
4744
4745 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4746
4747 lines, drawing - L<Imager::Draw/line()>
4748
4749 matrix - L<Imager::Matrix2d>,
4750 L<Imager::Engines/"Matrix Transformations">,
4751 L<Imager::Font/transform()>
4752
4753 metadata, image - L<Imager::ImageTypes/"Tags">
4754
4755 mosaic - L<Imager::Filters/mosaic>
4756
4757 noise, filter - L<Imager::Filters/noise>
4758
4759 noise, rendered - L<Imager::Filters/turbnoise>,
4760 L<Imager::Filters/radnoise>
4761
4762 paste - L<Imager::Transformations/paste()>,
4763 L<Imager::Transformations/rubthrough()>
4764
4765 pseudo-color image - L<Imager::ImageTypes/to_paletted()>,
4766 L<Imager::ImageTypes/new()>
4767
4768 =for stopwords posterize
4769
4770 posterize - L<Imager::Filters/postlevels>
4771
4772 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
4773
4774 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
4775
4776 rectangles, drawing - L<Imager::Draw/box()>
4777
4778 resizing an image - L<Imager::Transformations/scale()>,
4779 L<Imager::Transformations/crop()>
4780
4781 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4782
4783 saving an image - L<Imager::Files>
4784
4785 scaling - L<Imager::Transformations/scale()>
4786
4787 security - L<Imager::Security>
4788
4789 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4790
4791 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4792
4793 size, image - L<Imager::ImageTypes/getwidth()>,
4794 L<Imager::ImageTypes/getheight()>
4795
4796 size, text - L<Imager::Font/bounding_box()>
4797
4798 tags, image metadata - L<Imager::ImageTypes/"Tags">
4799
4800 text, drawing - L<Imager::Draw/string()>, L<Imager::Draw/align_string()>,
4801 L<Imager::Font::Wrap>
4802
4803 text, wrapping text in an area - L<Imager::Font::Wrap>
4804
4805 text, measuring - L<Imager::Font/bounding_box()>, L<Imager::Font::BBox>
4806
4807 tiles, color - L<Imager::Filters/mosaic>
4808
4809 transparent images - L<Imager::ImageTypes>,
4810 L<Imager::Cookbook/"Transparent PNG">
4811
4812 =for stopwords unsharp
4813
4814 unsharp mask - L<Imager::Filters/unsharpmask>
4815
4816 watermark - L<Imager::Filters/watermark>
4817
4818 writing an image to a file - L<Imager::Files>
4819
4820 =head1 THREADS
4821
4822 Imager doesn't support perl threads.
4823
4824 Imager has limited code to prevent double frees if you create images,
4825 colors etc, and then create a thread, but has no code to prevent two
4826 threads entering Imager's error handling code, and none is likely to
4827 be added.
4828
4829 =head1 SUPPORT
4830
4831 The best place to get help with Imager is the mailing list.
4832
4833 To subscribe send a message with C<subscribe> in the body to:
4834
4835    imager-devel+request@molar.is
4836
4837 or use the form at:
4838
4839 =over
4840
4841 L<http://www.molar.is/en/lists/imager-devel/>
4842
4843 =back
4844
4845 where you can also find the mailing list archive.
4846
4847 You can report bugs by pointing your browser at:
4848
4849 =over
4850
4851 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4852
4853 =back
4854
4855 or by sending an email to:
4856
4857 =over
4858
4859 bug-Imager@rt.cpan.org
4860
4861 =back
4862
4863 Please remember to include the versions of Imager, perl, supporting
4864 libraries, and any relevant code.  If you have specific images that
4865 cause the problems, please include those too.
4866
4867 If you don't want to publish your email address on a mailing list you
4868 can use CPAN::Forum:
4869
4870   http://www.cpanforum.com/dist/Imager
4871
4872 You will need to register to post.
4873
4874 =head1 CONTRIBUTING TO IMAGER
4875
4876 =head2 Feedback
4877
4878 I like feedback.
4879
4880 If you like or dislike Imager, you can add a public review of Imager
4881 at CPAN Ratings:
4882
4883   http://cpanratings.perl.org/dist/Imager
4884
4885 =for stopwords Bitcard
4886
4887 This requires a Bitcard account (http://www.bitcard.org).
4888
4889 You can also send email to the maintainer below.
4890
4891 If you send me a bug report via email, it will be copied to Request
4892 Tracker.
4893
4894 =head2 Patches
4895
4896 I accept patches, preferably against the master branch in git.  Please
4897 include an explanation of the reason for why the patch is needed or
4898 useful.
4899
4900 Your patch should include regression tests where possible, otherwise
4901 it will be delayed until I get a chance to write them.
4902
4903 To browse Imager's git repository:
4904
4905   http://git.imager.perl.org/imager.git
4906
4907 or:
4908
4909   https://github.com/tonycoz/imager
4910
4911 To clone:
4912
4913   git clone git://git.imager.perl.org/imager.git
4914
4915 or:
4916
4917   git clone git://github.com/tonycoz/imager.git
4918
4919 =head1 AUTHOR
4920
4921 Tony Cook <tonyc@cpan.org> is the current maintainer for Imager.
4922
4923 Arnar M. Hrafnkelsson is the original author of Imager.
4924
4925 Many others have contributed to Imager, please see the C<README> for a
4926 complete list.
4927
4928 =head1 LICENSE
4929
4930 Imager is licensed under the same terms as perl itself.
4931
4932 =for stopwords
4933 makeblendedfont Fontforge
4934
4935 A test font, generated by the Debian packaged Fontforge,
4936 F<FT2/fontfiles/MMOne.pfb>, contains a Postscript operator definition
4937 copyrighted by Adobe.  See F<adobe.txt> in the source for license
4938 information.
4939
4940 =head1 SEE ALSO
4941
4942 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4943 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4944 L<Imager::Font>(3), L<Imager::Transformations>(3),
4945 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4946 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4947
4948 L<http://imager.perl.org/>
4949
4950 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4951
4952 Other perl imaging modules include:
4953
4954 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3),
4955 L<Prima::Image>, L<IPA>.
4956
4957 If you're trying to use Imager for array processing, you should
4958 probably using L<PDL>.
4959
4960 =cut