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