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