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