Imager.pm

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