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 );
 121
 122 @EXPORT=qw(
 123            init_log
 124            i_list_formats
 125            i_has_format
 126            malloc_state
 127            i_color_new
 128
 129            i_img_empty
 130            i_img_empty_ch
 131           );
 132
 133 %EXPORT_TAGS=
 134   (handy => [qw(
 135                 newfont
 136                 newcolor
 137                 NF
 138                 NC
 139                )],
 140    all => [@EXPORT_OK],
 141    default => [qw(
 142                   load_plugin
 143                   unload_plugin
 144                  )]);
 145
 146 BEGIN {
 147   require Exporter;
 148   require DynaLoader;
 149
 150   $VERSION = '0.45';
 151   @ISA = qw(Exporter DynaLoader);
 152   bootstrap Imager $VERSION;
 153 }
 154
 155 BEGIN {
 156   i_init_fonts(); # Initialize font engines
 157   Imager::Font::__init();
 158   for(i_list_formats()) { $formats{$_}++; }
 159
 160   if ($formats{'t1'}) {
 161     i_t1_set_aa(1);
 162   }
 163
 164   if (!$formats{'t1'} and !$formats{'tt'}
 165       && !$formats{'ft2'} && !$formats{'w32'}) {
 166     $fontstate='no font support';
 167   }
 168
 169   %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
 170
 171   $DEBUG=0;
 172
 173   # the members of the subhashes under %filters are:
 174   #  callseq - a list of the parameters to the underlying filter in the
 175   #            order they are passed
 176   #  callsub - a code ref that takes a named parameter list and calls the
 177   #            underlying filter
 178   #  defaults - a hash of default values
 179   #  names - defines names for value of given parameters so if the names
 180   #          field is foo=> { bar=>1 }, and the user supplies "bar" as the
 181   #          foo parameter, the filter will receive 1 for the foo
 182   #          parameter
 183   $filters{contrast}={
 184                       callseq => ['image','intensity'],
 185                       callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
 186                      };
 187
 188   $filters{noise} ={
 189                     callseq => ['image', 'amount', 'subtype'],
 190                     defaults => { amount=>3,subtype=>0 },
 191                     callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
 192                    };
 193
 194   $filters{hardinvert} ={
 195                          callseq => ['image'],
 196                          defaults => { },
 197                          callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
 198                         };
 199
 200   $filters{autolevels} ={
 201                          callseq => ['image','lsat','usat','skew'],
 202                          defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
 203                          callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
 204                         };
 205
 206   $filters{turbnoise} ={
 207                         callseq => ['image'],
 208                         defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
 209                         callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
 210                        };
 211
 212   $filters{radnoise} ={
 213                        callseq => ['image'],
 214                        defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
 215                        callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
 216                       };
 217
 218   $filters{conv} ={
 219                        callseq => ['image', 'coef'],
 220                        defaults => { },
 221                        callsub => sub { my %hsh=@_; i_conv($hsh{image},$hsh{coef}); }
 222                       };
 223
 224   $filters{gradgen} =
 225     {
 226      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 227      defaults => { dist => 0 },
 228      callsub =>
 229      sub {
 230        my %hsh=@_;
 231        my @colors = @{$hsh{colors}};
 232        $_ = _color($_)
 233          for @colors;
 234        i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
 235      }
 236     };
 237
 238   $filters{nearest_color} ={
 239                             callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 240                             defaults => { },
 241                             callsub => sub { my %hsh=@_; i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, $hsh{colors}, $hsh{dist}); }
 242                            };
 243   $filters{gaussian} = {
 244                         callseq => [ 'image', 'stddev' ],
 245                         defaults => { },
 246                         callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
 247                        };
 248   $filters{mosaic} =
 249     {
 250      callseq => [ qw(image size) ],
 251      defaults => { size => 20 },
 252      callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
 253     };
 254   $filters{bumpmap} =
 255     {
 256      callseq => [ qw(image bump elevation lightx lighty st) ],
 257      defaults => { elevation=>0, st=> 2 },
 258      callsub => sub {
 259        my %hsh = @_;
 260        i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
 261                  $hsh{lightx}, $hsh{lighty}, $hsh{st});
 262      },
 263     };
 264   $filters{bumpmap_complex} =
 265     {
 266      callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
 267      defaults => {
 268                   channel => 0,
 269                   tx => 0,
 270                   ty => 0,
 271                   Lx => 0.2,
 272                   Ly => 0.4,
 273                   Lz => -1.0,
 274                   cd => 1.0,
 275                   cs => 40,
 276                   n => 1.3,
 277                   Ia => Imager::Color->new(rgb=>[0,0,0]),
 278                   Il => Imager::Color->new(rgb=>[255,255,255]),
 279                   Is => Imager::Color->new(rgb=>[255,255,255]),
 280                  },
 281      callsub => sub {
 282        my %hsh = @_;
 283        i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
 284                  $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
 285                  $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
 286                  $hsh{Is});
 287      },
 288     };
 289   $filters{postlevels} =
 290     {
 291      callseq  => [ qw(image levels) ],
 292      defaults => { levels => 10 },
 293      callsub  => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
 294     };
 295   $filters{watermark} =
 296     {
 297      callseq  => [ qw(image wmark tx ty pixdiff) ],
 298      defaults => { pixdiff=>10, tx=>0, ty=>0 },
 299      callsub  =>
 300      sub {
 301        my %hsh = @_;
 302        i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
 303                    $hsh{pixdiff});
 304      },
 305     };
 306   $filters{fountain} =
 307     {
 308      callseq  => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
 309      names    => {
 310                   ftype => { linear         => 0,
 311                              bilinear       => 1,
 312                              radial         => 2,
 313                              radial_square  => 3,
 314                              revolution     => 4,
 315                              conical        => 5 },
 316                   repeat => { none      => 0,
 317                               sawtooth  => 1,
 318                               triangle  => 2,
 319                               saw_both  => 3,
 320                               tri_both  => 4,
 321                             },
 322                   super_sample => {
 323                                    none    => 0,
 324                                    grid    => 1,
 325                                    random  => 2,
 326                                    circle  => 3,
 327                                   },
 328                   combine => {
 329                               none      => 0,
 330                               normal    => 1,
 331                               multiply  => 2, mult => 2,
 332                               dissolve  => 3,
 333                               add       => 4,
 334                               subtract  => 5, 'sub' => 5,
 335                               diff      => 6,
 336                               lighten   => 7,
 337                               darken    => 8,
 338                               hue       => 9,
 339                               sat       => 10,
 340                               value     => 11,
 341                               color     => 12,
 342                              },
 343                  },
 344      defaults => { ftype => 0, repeat => 0, combine => 0,
 345                    super_sample => 0, ssample_param => 4,
 346                    segments=>[
 347                               [ 0, 0.5, 1,
 348                                 Imager::Color->new(0,0,0),
 349                                 Imager::Color->new(255, 255, 255),
 350                                 0, 0,
 351                               ],
 352                              ],
 353                  },
 354      callsub  =>
 355      sub {
 356        my %hsh = @_;
 357
 358        # make sure the segments are specified with colors
 359        my @segments;
 360        for my $segment (@{$hsh{segments}}) {
 361          my @new_segment = @$segment;
 362
 363          $_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
 364          push @segments, \@new_segment;
 365        }
 366
 367        i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
 368                   $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
 369                   $hsh{ssample_param}, \@segments);
 370      },
 371     };
 372   $filters{unsharpmask} =
 373     {
 374      callseq => [ qw(image stddev scale) ],
 375      defaults => { stddev=>2.0, scale=>1.0 },
 376      callsub =>
 377      sub {
 378        my %hsh = @_;
 379        i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
 380      },
 381     };
 382
 383   $FORMATGUESS=\&def_guess_type;
 384
 385   $warn_obsolete = 1;
 386 }
 387
 388 #
 389 # Non methods
 390 #
 391
 392 # initlize Imager
 393 # NOTE: this might be moved to an import override later on
 394
 395 #sub import {
 396 #  my $pack = shift;
 397 #  (look through @_ for special tags, process, and remove them);
 398 #  use Data::Dumper;
 399 #  print Dumper($pack);
 400 #  print Dumper(@_);
 401 #}
 402
 403 sub init_log {
 404         m_init_log($_[0],$_[1]);
 405         log_entry("Imager $VERSION starting\n", 1);
 406 }
 407
 408
 409 sub init {
 410   my %parms=(loglevel=>1,@_);
 411   if ($parms{'log'}) {
 412     init_log($parms{'log'},$parms{'loglevel'});
 413   }
 414
 415   if (exists $parms{'warn_obsolete'}) {
 416     $warn_obsolete = $parms{'warn_obsolete'};
 417   }
 418
 419 #    if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
 420 #    if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
 421 #       i_init_fonts();
 422 #       $fontstate='ok';
 423 #    }
 424   if (exists $parms{'t1log'}) {
 425     i_init_fonts($parms{'t1log'});
 426   }
 427 }
 428
 429 END {
 430   if ($DEBUG) {
 431     print "shutdown code\n";
 432     #   for(keys %instances) { $instances{$_}->DESTROY(); }
 433     malloc_state(); # how do decide if this should be used? -- store something from the import
 434     print "Imager exiting\n";
 435   }
 436 }
 437
 438 # Load a filter plugin
 439
 440 sub load_plugin {
 441   my ($filename)=@_;
 442   my $i;
 443   my ($DSO_handle,$str)=DSO_open($filename);
 444   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
 445   my %funcs=DSO_funclist($DSO_handle);
 446   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
 447   $i=0;
 448   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
 449
 450   $DSOs{$filename}=[$DSO_handle,\%funcs];
 451
 452   for(keys %funcs) {
 453     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
 454     $DEBUG && print "eval string:\n",$evstr,"\n";
 455     eval $evstr;
 456     print $@ if $@;
 457   }
 458   return 1;
 459 }
 460
 461 # Unload a plugin
 462
 463 sub unload_plugin {
 464   my ($filename)=@_;
 465
 466   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
 467   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
 468   for(keys %{$funcref}) {
 469     delete $filters{$_};
 470     $DEBUG && print "unloading: $_\n";
 471   }
 472   my $rc=DSO_close($DSO_handle);
 473   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
 474   return 1;
 475 }
 476
 477 # take the results of i_error() and make a message out of it
 478 sub _error_as_msg {
 479   return join(": ", map $_->[0], i_errors());
 480 }
 481
 482 # this function tries to DWIM for color parameters
 483 #  color objects are used as is
 484 #  simple scalars are simply treated as single parameters to Imager::Color->new
 485 #  hashrefs are treated as named argument lists to Imager::Color->new
 486 #  arrayrefs are treated as list arguments to Imager::Color->new iff any
 487 #    parameter is > 1
 488 #  other arrayrefs are treated as list arguments to Imager::Color::Float
 489
 490 sub _color {
 491   my $arg = shift;
 492   # perl 5.6.0 seems to do weird things to $arg if we don't make an
 493   # explicitly stringified copy
 494   # I vaguely remember a bug on this on p5p, but couldn't find it
 495   # through bugs.perl.org (I had trouble getting it to find any bugs)
 496   my $copy = $arg . "";
 497   my $result;
 498
 499   if (ref $arg) {
 500     if (UNIVERSAL::isa($arg, "Imager::Color")
 501         || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
 502       $result = $arg;
 503     }
 504     else {
 505       if ($copy =~ /^HASH\(/) {
 506         $result = Imager::Color->new(%$arg);
 507       }
 508       elsif ($copy =~ /^ARRAY\(/) {
 509         if (grep $_ > 1, @$arg) {
 510           $result = Imager::Color->new(@$arg);
 511         }
 512         else {
 513           $result = Imager::Color::Float->new(@$arg);
 514         }
 515       }
 516       else {
 517         $Imager::ERRSTR = "Not a color";
 518       }
 519     }
 520   }
 521   else {
 522     # assume Imager::Color::new knows how to handle it
 523     $result = Imager::Color->new($arg);
 524   }
 525
 526   return $result;
 527 }
 528
 529
 530 #
 531 # Methods to be called on objects.
 532 #
 533
 534 # Create a new Imager object takes very few parameters.
 535 # usually you call this method and then call open from
 536 # the resulting object
 537
 538 sub new {
 539   my $class = shift;
 540   my $self ={};
 541   my %hsh=@_;
 542   bless $self,$class;
 543   $self->{IMG}=undef;    # Just to indicate what exists
 544   $self->{ERRSTR}=undef; #
 545   $self->{DEBUG}=$DEBUG;
 546   $self->{DEBUG} && print "Initialized Imager\n";
 547   if (defined $hsh{xsize} && defined $hsh{ysize}) {
 548     unless ($self->img_set(%hsh)) {
 549       $Imager::ERRSTR = $self->{ERRSTR};
 550       return;
 551     }
 552   }
 553   return $self;
 554 }
 555
 556 # Copy an entire image with no changes
 557 # - if an image has magic the copy of it will not be magical
 558
 559 sub copy {
 560   my $self = shift;
 561   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 562
 563   unless (defined wantarray) {
 564     my @caller = caller;
 565     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
 566     return;
 567   }
 568
 569   my $newcopy=Imager->new();
 570   $newcopy->{IMG}=i_img_new();
 571   i_copy($newcopy->{IMG},$self->{IMG});
 572   return $newcopy;
 573 }
 574
 575 # Paste a region
 576
 577 sub paste {
 578   my $self = shift;
 579   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 580   my %input=(left=>0, top=>0, @_);
 581   unless($input{img}) {
 582     $self->{ERRSTR}="no source image";
 583     return;
 584   }
 585   $input{left}=0 if $input{left} <= 0;
 586   $input{top}=0 if $input{top} <= 0;
 587   my $src=$input{img};
 588   my($r,$b)=i_img_info($src->{IMG});
 589
 590   i_copyto($self->{IMG}, $src->{IMG},
 591            0,0, $r, $b, $input{left}, $input{top});
 592   return $self;  # What should go here??
 593 }
 594
 595 # Crop an image - i.e. return a new image that is smaller
 596
 597 sub crop {
 598   my $self=shift;
 599   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 600
 601   unless (defined wantarray) {
 602     my @caller = caller;
 603     warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
 604     return;
 605   }
 606
 607   my %hsh=@_;
 608
 609   my ($w, $h, $l, $r, $b, $t) =
 610     @hsh{qw(width height left right bottom top)};
 611
 612   # work through the various possibilities
 613   if (defined $l) {
 614     if (defined $w) {
 615       $r = $l + $w;
 616     }
 617     elsif (!defined $r) {
 618       $r = $self->getwidth;
 619     }
 620   }
 621   elsif (defined $r) {
 622     if (defined $w) {
 623       $l = $r - $w;
 624     }
 625     else {
 626       $l = 0;
 627     }
 628   }
 629   elsif (defined $w) {
 630     $l = int(0.5+($self->getwidth()-$w)/2);
 631     $r = $l + $w;
 632   }
 633   else {
 634     $l = 0;
 635     $r = $self->getwidth;
 636   }
 637   if (defined $t) {
 638     if (defined $h) {
 639       $b = $t + $h;
 640     }
 641     elsif (!defined $b) {
 642       $b = $self->getheight;
 643     }
 644   }
 645   elsif (defined $b) {
 646     if (defined $h) {
 647       $t = $b - $h;
 648     }
 649     else {
 650       $t = 0;
 651     }
 652   }
 653   elsif (defined $h) {
 654     $t=int(0.5+($self->getheight()-$h)/2);
 655     $b=$t+$h;
 656   }
 657   else {
 658     $t = 0;
 659     $b = $self->getheight;
 660   }
 661
 662   ($l,$r)=($r,$l) if $l>$r;
 663   ($t,$b)=($b,$t) if $t>$b;
 664
 665   $l < 0 and $l = 0;
 666   $r > $self->getwidth and $r = $self->getwidth;
 667   $t < 0 and $t = 0;
 668   $b > $self->getheight and $b = $self->getheight;
 669
 670   if ($l == $r || $t == $b) {
 671     $self->_set_error("resulting image would have no content");
 672     return;
 673   }
 674
 675   my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
 676
 677   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
 678   return $dst;
 679 }
 680
 681 sub _sametype {
 682   my ($self, %opts) = @_;
 683
 684   $self->{IMG} or return $self->_set_error("Not a valid image");
 685
 686   my $x = $opts{xsize} || $self->getwidth;
 687   my $y = $opts{ysize} || $self->getheight;
 688   my $channels = $opts{channels} || $self->getchannels;
 689
 690   my $out = Imager->new;
 691   if ($channels == $self->getchannels) {
 692     $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
 693   }
 694   else {
 695     $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
 696   }
 697   unless ($out->{IMG}) {
 698     $self->{ERRSTR} = $self->_error_as_msg;
 699     return;
 700   }
 701
 702   return $out;
 703 }
 704
 705 # Sets an image to a certain size and channel number
 706 # if there was previously data in the image it is discarded
 707
 708 sub img_set {
 709   my $self=shift;
 710
 711   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
 712
 713   if (defined($self->{IMG})) {
 714     # let IIM_DESTROY destroy it, it's possible this image is
 715     # referenced from a virtual image (like masked)
 716     #i_img_destroy($self->{IMG});
 717     undef($self->{IMG});
 718   }
 719
 720   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
 721     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
 722                                  $hsh{maxcolors} || 256);
 723   }
 724   elsif ($hsh{bits} eq 'double') {
 725     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 726   }
 727   elsif ($hsh{bits} == 16) {
 728     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 729   }
 730   else {
 731     $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
 732                                      $hsh{'channels'});
 733   }
 734
 735   unless ($self->{IMG}) {
 736     $self->{ERRSTR} = Imager->_error_as_msg();
 737     return;
 738   }
 739
 740   $self;
 741 }
 742
 743 # created a masked version of the current image
 744 sub masked {
 745   my $self = shift;
 746
 747   $self or return undef;
 748   my %opts = (left    => 0,
 749               top     => 0,
 750               right   => $self->getwidth,
 751               bottom  => $self->getheight,
 752               @_);
 753   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
 754
 755   my $result = Imager->new;
 756   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
 757                                     $opts{top}, $opts{right} - $opts{left},
 758                                     $opts{bottom} - $opts{top});
 759   # keep references to the mask and base images so they don't
 760   # disappear on us
 761   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
 762
 763   $result;
 764 }
 765
 766 # convert an RGB image into a paletted image
 767 sub to_paletted {
 768   my $self = shift;
 769   my $opts;
 770   if (@_ != 1 && !ref $_[0]) {
 771     $opts = { @_ };
 772   }
 773   else {
 774     $opts = shift;
 775   }
 776
 777   unless (defined wantarray) {
 778     my @caller = caller;
 779     warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
 780     return;
 781   }
 782
 783   my $result = Imager->new;
 784   $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
 785
 786   #print "Type ", i_img_type($result->{IMG}), "\n";
 787
 788   if ($result->{IMG}) {
 789     return $result;
 790   }
 791   else {
 792     $self->{ERRSTR} = $self->_error_as_msg;
 793     return;
 794   }
 795 }
 796
 797 # convert a paletted (or any image) to an 8-bit/channel RGB images
 798 sub to_rgb8 {
 799   my $self = shift;
 800   my $result;
 801
 802   unless (defined wantarray) {
 803     my @caller = caller;
 804     warn "to_rgb8() called in void context - to_rgb8() returns the cropped image at $caller[1] line $caller[2]\n";
 805     return;
 806   }
 807
 808   if ($self->{IMG}) {
 809     $result = Imager->new;
 810     $result->{IMG} = i_img_to_rgb($self->{IMG})
 811       or undef $result;
 812   }
 813
 814   return $result;
 815 }
 816
 817 sub addcolors {
 818   my $self = shift;
 819   my %opts = (colors=>[], @_);
 820
 821   @{$opts{colors}} or return undef;
 822
 823   $self->{IMG} and i_addcolors($self->{IMG}, @{$opts{colors}});
 824 }
 825
 826 sub setcolors {
 827   my $self = shift;
 828   my %opts = (start=>0, colors=>[], @_);
 829   @{$opts{colors}} or return undef;
 830
 831   $self->{IMG} and i_setcolors($self->{IMG}, $opts{start}, @{$opts{colors}});
 832 }
 833
 834 sub getcolors {
 835   my $self = shift;
 836   my %opts = @_;
 837   if (!exists $opts{start} && !exists $opts{count}) {
 838     # get them all
 839     $opts{start} = 0;
 840     $opts{count} = $self->colorcount;
 841   }
 842   elsif (!exists $opts{count}) {
 843     $opts{count} = 1;
 844   }
 845   elsif (!exists $opts{start}) {
 846     $opts{start} = 0;
 847   }
 848
 849   $self->{IMG} and
 850     return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
 851 }
 852
 853 sub colorcount {
 854   i_colorcount($_[0]{IMG});
 855 }
 856
 857 sub maxcolors {
 858   i_maxcolors($_[0]{IMG});
 859 }
 860
 861 sub findcolor {
 862   my $self = shift;
 863   my %opts = @_;
 864   $opts{color} or return undef;
 865
 866   $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
 867 }
 868
 869 sub bits {
 870   my $self = shift;
 871   my $bits = $self->{IMG} && i_img_bits($self->{IMG});
 872   if ($bits && $bits == length(pack("d", 1)) * 8) {
 873     $bits = 'double';
 874   }
 875   $bits;
 876 }
 877
 878 sub type {
 879   my $self = shift;
 880   if ($self->{IMG}) {
 881     return i_img_type($self->{IMG}) ? "paletted" : "direct";
 882   }
 883 }
 884
 885 sub virtual {
 886   my $self = shift;
 887   $self->{IMG} and i_img_virtual($self->{IMG});
 888 }
 889
 890 sub tags {
 891   my ($self, %opts) = @_;
 892
 893   $self->{IMG} or return;
 894
 895   if (defined $opts{name}) {
 896     my @result;
 897     my $start = 0;
 898     my $found;
 899     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
 900       push @result, (i_tags_get($self->{IMG}, $found))[1];
 901       $start = $found+1;
 902     }
 903     return wantarray ? @result : $result[0];
 904   }
 905   elsif (defined $opts{code}) {
 906     my @result;
 907     my $start = 0;
 908     my $found;
 909     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
 910       push @result, (i_tags_get($self->{IMG}, $found))[1];
 911       $start = $found+1;
 912     }
 913     return @result;
 914   }
 915   else {
 916     if (wantarray) {
 917       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
 918     }
 919     else {
 920       return i_tags_count($self->{IMG});
 921     }
 922   }
 923 }
 924
 925 sub addtag {
 926   my $self = shift;
 927   my %opts = @_;
 928
 929   return -1 unless $self->{IMG};
 930   if ($opts{name}) {
 931     if (defined $opts{value}) {
 932       if ($opts{value} =~ /^\d+$/) {
 933         # add as a number
 934         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
 935       }
 936       else {
 937         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
 938       }
 939     }
 940     elsif (defined $opts{data}) {
 941       # force addition as a string
 942       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
 943     }
 944     else {
 945       $self->{ERRSTR} = "No value supplied";
 946       return undef;
 947     }
 948   }
 949   elsif ($opts{code}) {
 950     if (defined $opts{value}) {
 951       if ($opts{value} =~ /^\d+$/) {
 952         # add as a number
 953         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
 954       }
 955       else {
 956         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
 957       }
 958     }
 959     elsif (defined $opts{data}) {
 960       # force addition as a string
 961       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
 962     }
 963     else {
 964       $self->{ERRSTR} = "No value supplied";
 965       return undef;
 966     }
 967   }
 968   else {
 969     return undef;
 970   }
 971 }
 972
 973 sub deltag {
 974   my $self = shift;
 975   my %opts = @_;
 976
 977   return 0 unless $self->{IMG};
 978
 979   if (defined $opts{'index'}) {
 980     return i_tags_delete($self->{IMG}, $opts{'index'});
 981   }
 982   elsif (defined $opts{name}) {
 983     return i_tags_delbyname($self->{IMG}, $opts{name});
 984   }
 985   elsif (defined $opts{code}) {
 986     return i_tags_delbycode($self->{IMG}, $opts{code});
 987   }
 988   else {
 989     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
 990     return 0;
 991   }
 992 }
 993
 994 sub settag {
 995   my ($self, %opts) = @_;
 996
 997   if ($opts{name}) {
 998     $self->deltag(name=>$opts{name});
 999     return $self->addtag(name=>$opts{name}, value=>$opts{value});
1000   }
1001   elsif (defined $opts{code}) {
1002     $self->deltag(code=>$opts{code});
1003     return $self->addtag(code=>$opts{code}, value=>$opts{value});
1004   }
1005   else {
1006     return undef;
1007   }
1008 }
1009
1010
1011 sub _get_reader_io {
1012   my ($self, $input) = @_;
1013
1014         if ($input->{io}) {
1015                 return $input->{io}, undef;
1016         }
1017   elsif ($input->{fd}) {
1018     return io_new_fd($input->{fd});
1019   }
1020   elsif ($input->{fh}) {
1021     my $fd = fileno($input->{fh});
1022     unless ($fd) {
1023       $self->_set_error("Handle in fh option not opened");
1024       return;
1025     }
1026     return io_new_fd($fd);
1027   }
1028   elsif ($input->{file}) {
1029     my $file = IO::File->new($input->{file}, "r");
1030     unless ($file) {
1031       $self->_set_error("Could not open $input->{file}: $!");
1032       return;
1033     }
1034     binmode $file;
1035     return (io_new_fd(fileno($file)), $file);
1036   }
1037   elsif ($input->{data}) {
1038     return io_new_buffer($input->{data});
1039   }
1040   elsif ($input->{callback} || $input->{readcb}) {
1041     if (!$input->{seekcb}) {
1042       $self->_set_error("Need a seekcb parameter");
1043     }
1044     if ($input->{maxbuffer}) {
1045       return io_new_cb($input->{writecb},
1046                        $input->{callback} || $input->{readcb},
1047                        $input->{seekcb}, $input->{closecb},
1048                        $input->{maxbuffer});
1049     }
1050     else {
1051       return io_new_cb($input->{writecb},
1052                        $input->{callback} || $input->{readcb},
1053                        $input->{seekcb}, $input->{closecb});
1054     }
1055   }
1056   else {
1057     $self->_set_error("file/fd/fh/data/callback parameter missing");
1058     return;
1059   }
1060 }
1061
1062 sub _get_writer_io {
1063   my ($self, $input, $type) = @_;
1064
1065   if ($input->{fd}) {
1066     return io_new_fd($input->{fd});
1067   }
1068   elsif ($input->{fh}) {
1069     my $fd = fileno($input->{fh});
1070     unless ($fd) {
1071       $self->_set_error("Handle in fh option not opened");
1072       return;
1073     }
1074     # flush it
1075     my $oldfh = select($input->{fh});
1076     # flush anything that's buffered, and make sure anything else is flushed
1077     $| = 1;
1078     select($oldfh);
1079     return io_new_fd($fd);
1080   }
1081   elsif ($input->{file}) {
1082     my $fh = new IO::File($input->{file},"w+");
1083     unless ($fh) {
1084       $self->_set_error("Could not open file $input->{file}: $!");
1085       return;
1086     }
1087     binmode($fh) or die;
1088     return (io_new_fd(fileno($fh)), $fh);
1089   }
1090   elsif ($input->{data}) {
1091     return io_new_bufchain();
1092   }
1093   elsif ($input->{callback} || $input->{writecb}) {
1094     if ($input->{maxbuffer}) {
1095       return io_new_cb($input->{callback} || $input->{writecb},
1096                        $input->{readcb},
1097                        $input->{seekcb}, $input->{closecb},
1098                        $input->{maxbuffer});
1099     }
1100     else {
1101       return io_new_cb($input->{callback} || $input->{writecb},
1102                        $input->{readcb},
1103                        $input->{seekcb}, $input->{closecb});
1104     }
1105   }
1106   else {
1107     $self->_set_error("file/fd/fh/data/callback parameter missing");
1108     return;
1109   }
1110 }
1111
1112 # Read an image from file
1113
1114 sub read {
1115   my $self = shift;
1116   my %input=@_;
1117
1118   if (defined($self->{IMG})) {
1119     # let IIM_DESTROY do the destruction, since the image may be
1120     # referenced from elsewhere
1121     #i_img_destroy($self->{IMG});
1122     undef($self->{IMG});
1123   }
1124
1125   my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1126
1127   unless ($input{'type'}) {
1128     $input{'type'} = i_test_format_probe($IO, -1);
1129   }
1130
1131   unless ($input{'type'}) {
1132           $self->_set_error('type parameter missing and not possible to guess from extension');
1133     return undef;
1134   }
1135
1136   unless ($formats{$input{'type'}}) {
1137     $self->_set_error("format '$input{'type'}' not supported");
1138     return;
1139   }
1140
1141   # Setup data source
1142   if ( $input{'type'} eq 'jpeg' ) {
1143     ($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
1144     if ( !defined($self->{IMG}) ) {
1145       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1146     }
1147     $self->{DEBUG} && print "loading a jpeg file\n";
1148     return $self;
1149   }
1150
1151   if ( $input{'type'} eq 'tiff' ) {
1152     my $page = $input{'page'};
1153     defined $page or $page = 0;
1154     # Fixme, check if that length parameter is ever needed
1155     $self->{IMG}=i_readtiff_wiol( $IO, -1, $page );
1156     if ( !defined($self->{IMG}) ) {
1157       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1158     }
1159     $self->{DEBUG} && print "loading a tiff file\n";
1160     return $self;
1161   }
1162
1163   if ( $input{'type'} eq 'pnm' ) {
1164     $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1165     if ( !defined($self->{IMG}) ) {
1166       $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
1167     }
1168     $self->{DEBUG} && print "loading a pnm file\n";
1169     return $self;
1170   }
1171
1172   if ( $input{'type'} eq 'png' ) {
1173     $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1174     if ( !defined($self->{IMG}) ) {
1175       $self->{ERRSTR} = $self->_error_as_msg();
1176       return undef;
1177     }
1178     $self->{DEBUG} && print "loading a png file\n";
1179   }
1180
1181   if ( $input{'type'} eq 'bmp' ) {
1182     $self->{IMG}=i_readbmp_wiol( $IO );
1183     if ( !defined($self->{IMG}) ) {
1184       $self->{ERRSTR}=$self->_error_as_msg();
1185       return undef;
1186     }
1187     $self->{DEBUG} && print "loading a bmp file\n";
1188   }
1189
1190   if ( $input{'type'} eq 'gif' ) {
1191     if ($input{colors} && !ref($input{colors})) {
1192       # must be a reference to a scalar that accepts the colour map
1193       $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1194       return undef;
1195     }
1196     if ($input{'gif_consolidate'}) {
1197       if ($input{colors}) {
1198         my $colors;
1199         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1200         if ($colors) {
1201           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1202         }
1203       }
1204       else {
1205         $self->{IMG} =i_readgif_wiol( $IO );
1206       }
1207     }
1208     else {
1209       my $page = $input{'page'};
1210       defined $page or $page = 0;
1211       $self->{IMG} = i_readgif_single_wiol( $IO, $page );
1212       if ($input{colors}) {
1213         ${ $input{colors} } =
1214           [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ];
1215       }
1216     }
1217
1218     if ( !defined($self->{IMG}) ) {
1219       $self->{ERRSTR}=$self->_error_as_msg();
1220       return undef;
1221     }
1222     $self->{DEBUG} && print "loading a gif file\n";
1223   }
1224
1225   if ( $input{'type'} eq 'tga' ) {
1226     $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1227     if ( !defined($self->{IMG}) ) {
1228       $self->{ERRSTR}=$self->_error_as_msg();
1229       return undef;
1230     }
1231     $self->{DEBUG} && print "loading a tga file\n";
1232   }
1233
1234   if ( $input{'type'} eq 'rgb' ) {
1235     $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1236     if ( !defined($self->{IMG}) ) {
1237       $self->{ERRSTR}=$self->_error_as_msg();
1238       return undef;
1239     }
1240     $self->{DEBUG} && print "loading a tga file\n";
1241   }
1242
1243
1244   if ( $input{'type'} eq 'raw' ) {
1245     my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1246
1247     if ( !($params{xsize} && $params{ysize}) ) {
1248       $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1249       return undef;
1250     }
1251
1252     $self->{IMG} = i_readraw_wiol( $IO,
1253                                    $params{xsize},
1254                                    $params{ysize},
1255                                    $params{datachannels},
1256                                    $params{storechannels},
1257                                    $params{interleave});
1258     if ( !defined($self->{IMG}) ) {
1259       $self->{ERRSTR}='unable to read raw image';
1260       return undef;
1261     }
1262     $self->{DEBUG} && print "loading a raw file\n";
1263   }
1264
1265   return $self;
1266 }
1267
1268 sub _fix_gif_positions {
1269   my ($opts, $opt, $msg, @imgs) = @_;
1270
1271   my $positions = $opts->{'gif_positions'};
1272   my $index = 0;
1273   for my $pos (@$positions) {
1274     my ($x, $y) = @$pos;
1275     my $img = $imgs[$index++];
1276     $img->settag(name=>'gif_left', value=>$x);
1277     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1278   }
1279   $$msg .= "replaced with the gif_left and gif_top tags";
1280 }
1281
1282 my %obsolete_opts =
1283   (
1284    gif_each_palette=>'gif_local_map',
1285    interlace       => 'gif_interlace',
1286    gif_delays => 'gif_delay',
1287    gif_positions => \&_fix_gif_positions,
1288    gif_loop_count => 'gif_loop',
1289   );
1290
1291 sub _set_opts {
1292   my ($self, $opts, $prefix, @imgs) = @_;
1293
1294   for my $opt (keys %$opts) {
1295     my $tagname = $opt;
1296     if ($obsolete_opts{$opt}) {
1297       my $new = $obsolete_opts{$opt};
1298       my $msg = "Obsolete option $opt ";
1299       if (ref $new) {
1300         $new->($opts, $opt, \$msg, @imgs);
1301       }
1302       else {
1303         $msg .= "replaced with the $new tag ";
1304         $tagname = $new;
1305       }
1306       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1307       warn $msg if $warn_obsolete && $^W;
1308     }
1309     next unless $tagname =~ /^\Q$prefix/;
1310     my $value = $opts->{$opt};
1311     if (ref $value) {
1312       if (UNIVERSAL::isa($value, "Imager::Color")) {
1313         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1314         for my $img (@imgs) {
1315           $img->settag(name=>$tagname, value=>$tag);
1316         }
1317       }
1318       elsif (ref($value) eq 'ARRAY') {
1319         for my $i (0..$#$value) {
1320           my $val = $value->[$i];
1321           if (ref $val) {
1322             if (UNIVERSAL::isa($val, "Imager::Color")) {
1323               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1324               $i < @imgs and
1325                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1326             }
1327             else {
1328               $self->_set_error("Unknown reference type " . ref($value) .
1329                                 " supplied in array for $opt");
1330               return;
1331             }
1332           }
1333           else {
1334             $i < @imgs
1335               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1336           }
1337         }
1338       }
1339       else {
1340         $self->_set_error("Unknown reference type " . ref($value) .
1341                           " supplied for $opt");
1342         return;
1343       }
1344     }
1345     else {
1346       # set it as a tag for every image
1347       for my $img (@imgs) {
1348         $img->settag(name=>$tagname, value=>$value);
1349       }
1350     }
1351   }
1352
1353   return 1;
1354 }
1355
1356 # Write an image to file
1357 sub write {
1358   my $self = shift;
1359   my %input=(jpegquality=>75,
1360              gifquant=>'mc',
1361              lmdither=>6.0,
1362              lmfixed=>[],
1363              idstring=>"",
1364              compress=>1,
1365              wierdpack=>0,
1366              fax_fine=>1, @_);
1367   my $rc;
1368
1369   $self->_set_opts(\%input, "i_", $self)
1370     or return undef;
1371
1372   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1373
1374   if (!$input{'type'} and $input{file}) {
1375     $input{'type'}=$FORMATGUESS->($input{file});
1376   }
1377   if (!$input{'type'}) {
1378     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1379     return undef;
1380   }
1381
1382   if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
1383
1384   my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1385     or return undef;
1386
1387   if ($input{'type'} eq 'tiff') {
1388     $self->_set_opts(\%input, "tiff_", $self)
1389       or return undef;
1390     $self->_set_opts(\%input, "exif_", $self)
1391       or return undef;
1392
1393     if (defined $input{class} && $input{class} eq 'fax') {
1394       if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1395         $self->{ERRSTR}='Could not write to buffer';
1396         return undef;
1397       }
1398     } else {
1399       if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1400         $self->{ERRSTR}='Could not write to buffer';
1401         return undef;
1402       }
1403     }
1404   } elsif ( $input{'type'} eq 'pnm' ) {
1405     $self->_set_opts(\%input, "pnm_", $self)
1406       or return undef;
1407     if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1408       $self->{ERRSTR}='unable to write pnm image';
1409       return undef;
1410     }
1411     $self->{DEBUG} && print "writing a pnm file\n";
1412   } elsif ( $input{'type'} eq 'raw' ) {
1413     $self->_set_opts(\%input, "raw_", $self)
1414       or return undef;
1415     if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1416       $self->{ERRSTR}='unable to write raw image';
1417       return undef;
1418     }
1419     $self->{DEBUG} && print "writing a raw file\n";
1420   } elsif ( $input{'type'} eq 'png' ) {
1421     $self->_set_opts(\%input, "png_", $self)
1422       or return undef;
1423     if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1424       $self->{ERRSTR}='unable to write png image';
1425       return undef;
1426     }
1427     $self->{DEBUG} && print "writing a png file\n";
1428   } elsif ( $input{'type'} eq 'jpeg' ) {
1429     $self->_set_opts(\%input, "jpeg_", $self)
1430       or return undef;
1431     $self->_set_opts(\%input, "exif_", $self)
1432       or return undef;
1433     if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1434       $self->{ERRSTR} = $self->_error_as_msg();
1435       return undef;
1436     }
1437     $self->{DEBUG} && print "writing a jpeg file\n";
1438   } elsif ( $input{'type'} eq 'bmp' ) {
1439     $self->_set_opts(\%input, "bmp_", $self)
1440       or return undef;
1441     if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1442       $self->{ERRSTR}='unable to write bmp image';
1443       return undef;
1444     }
1445     $self->{DEBUG} && print "writing a bmp file\n";
1446   } elsif ( $input{'type'} eq 'tga' ) {
1447     $self->_set_opts(\%input, "tga_", $self)
1448       or return undef;
1449
1450     if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1451       $self->{ERRSTR}=$self->_error_as_msg();
1452       return undef;
1453     }
1454     $self->{DEBUG} && print "writing a tga file\n";
1455   } elsif ( $input{'type'} eq 'gif' ) {
1456     $self->_set_opts(\%input, "gif_", $self)
1457       or return undef;
1458     # compatibility with the old interfaces
1459     if ($input{gifquant} eq 'lm') {
1460       $input{make_colors} = 'addi';
1461       $input{translate} = 'perturb';
1462       $input{perturb} = $input{lmdither};
1463     } elsif ($input{gifquant} eq 'gen') {
1464       # just pass options through
1465     } else {
1466       $input{make_colors} = 'webmap'; # ignored
1467       $input{translate} = 'giflib';
1468     }
1469     if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1470       $self->{ERRSTR} = $self->_error_as_msg;
1471       return;
1472     }
1473   }
1474
1475   if (exists $input{'data'}) {
1476     my $data = io_slurp($IO);
1477     if (!$data) {
1478       $self->{ERRSTR}='Could not slurp from buffer';
1479       return undef;
1480     }
1481     ${$input{data}} = $data;
1482   }
1483   return $self;
1484 }
1485
1486 sub write_multi {
1487   my ($class, $opts, @images) = @_;
1488
1489   if (!$opts->{'type'} && $opts->{'file'}) {
1490     $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1491   }
1492   unless ($opts->{'type'}) {
1493     $class->_set_error('type parameter missing and not possible to guess from extension');
1494     return;
1495   }
1496   # translate to ImgRaw
1497   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1498     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1499     return 0;
1500   }
1501   $class->_set_opts($opts, "i_", @images)
1502     or return;
1503   my @work = map $_->{IMG}, @images;
1504   my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1505     or return undef;
1506   if ($opts->{'type'} eq 'gif') {
1507     $class->_set_opts($opts, "gif_", @images)
1508       or return;
1509     my $gif_delays = $opts->{gif_delays};
1510     local $opts->{gif_delays} = $gif_delays;
1511     if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1512       # assume the caller wants the same delay for each frame
1513       $opts->{gif_delays} = [ ($gif_delays) x @images ];
1514     }
1515     my $res = i_writegif_wiol($IO, $opts, @work);
1516     $res or $class->_set_error($class->_error_as_msg());
1517     return $res;
1518   }
1519   elsif ($opts->{'type'} eq 'tiff') {
1520     $class->_set_opts($opts, "tiff_", @images)
1521       or return;
1522     $class->_set_opts($opts, "exif_", @images)
1523       or return;
1524     my $res;
1525     $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1526     if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1527       $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1528     }
1529     else {
1530       $res = i_writetiff_multi_wiol($IO, @work);
1531     }
1532     $res or $class->_set_error($class->_error_as_msg());
1533     return $res;
1534   }
1535   else {
1536     $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
1537     return 0;
1538   }
1539 }
1540
1541 # read multiple images from a file
1542 sub read_multi {
1543   my ($class, %opts) = @_;
1544
1545   if ($opts{file} && !exists $opts{'type'}) {
1546     # guess the type
1547     my $type = $FORMATGUESS->($opts{file});
1548     $opts{'type'} = $type;
1549   }
1550   unless ($opts{'type'}) {
1551     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1552     return;
1553   }
1554
1555   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1556     or return;
1557   if ($opts{'type'} eq 'gif') {
1558     my @imgs;
1559     @imgs = i_readgif_multi_wiol($IO);
1560     if (@imgs) {
1561       return map {
1562         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1563       } @imgs;
1564     }
1565     else {
1566       $ERRSTR = _error_as_msg();
1567       return;
1568     }
1569   }
1570   elsif ($opts{'type'} eq 'tiff') {
1571     my @imgs = i_readtiff_multi_wiol($IO, -1);
1572     if (@imgs) {
1573       return map {
1574         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1575       } @imgs;
1576     }
1577     else {
1578       $ERRSTR = _error_as_msg();
1579       return;
1580     }
1581   }
1582
1583   $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
1584   return;
1585 }
1586
1587 # Destroy an Imager object
1588
1589 sub DESTROY {
1590   my $self=shift;
1591   #    delete $instances{$self};
1592   if (defined($self->{IMG})) {
1593     # the following is now handled by the XS DESTROY method for
1594     # Imager::ImgRaw object
1595     # Re-enabling this will break virtual images
1596     # tested for in t/t020masked.t
1597     # i_img_destroy($self->{IMG});
1598     undef($self->{IMG});
1599   } else {
1600 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1601   }
1602 }
1603
1604 # Perform an inplace filter of an image
1605 # that is the image will be overwritten with the data
1606
1607 sub filter {
1608   my $self=shift;
1609   my %input=@_;
1610   my %hsh;
1611   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1612
1613   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1614
1615   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1616     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1617   }
1618
1619   if ($filters{$input{'type'}}{names}) {
1620     my $names = $filters{$input{'type'}}{names};
1621     for my $name (keys %$names) {
1622       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1623         $input{$name} = $names->{$name}{$input{$name}};
1624       }
1625     }
1626   }
1627   if (defined($filters{$input{'type'}}{defaults})) {
1628     %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
1629   } else {
1630     %hsh=('image',$self->{IMG},%input);
1631   }
1632
1633   my @cs=@{$filters{$input{'type'}}{callseq}};
1634
1635   for(@cs) {
1636     if (!defined($hsh{$_})) {
1637       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1638     }
1639   }
1640
1641   eval {
1642     local $SIG{__DIE__}; # we don't want this processed by confess, etc
1643     &{$filters{$input{'type'}}{callsub}}(%hsh);
1644   };
1645   if ($@) {
1646     chomp($self->{ERRSTR} = $@);
1647     return;
1648   }
1649
1650   my @b=keys %hsh;
1651
1652   $self->{DEBUG} && print "callseq is: @cs\n";
1653   $self->{DEBUG} && print "matching callseq is: @b\n";
1654
1655   return $self;
1656 }
1657
1658 # Scale an image to requested size and return the scaled version
1659
1660 sub scale {
1661   my $self=shift;
1662   my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
1663   my $img = Imager->new();
1664   my $tmp = Imager->new();
1665
1666   unless (defined wantarray) {
1667     my @caller = caller;
1668     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
1669     return;
1670   }
1671
1672   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1673
1674   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
1675     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
1676     if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1677     if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
1678   } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1679   elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1680
1681   if ($opts{qtype} eq 'normal') {
1682     $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1683     if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1684     $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1685     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1686     return $img;
1687   }
1688   if ($opts{'qtype'} eq 'preview') {
1689     $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
1690     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1691     return $img;
1692   }
1693   $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1694 }
1695
1696 # Scales only along the X axis
1697
1698 sub scaleX {
1699   my $self=shift;
1700   my %opts=(scalefactor=>0.5,@_);
1701
1702   unless (defined wantarray) {
1703     my @caller = caller;
1704     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
1705     return;
1706   }
1707
1708   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1709
1710   my $img = Imager->new();
1711
1712   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1713
1714   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1715   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1716
1717   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1718   return $img;
1719 }
1720
1721 # Scales only along the Y axis
1722
1723 sub scaleY {
1724   my $self=shift;
1725   my %opts=(scalefactor=>0.5,@_);
1726
1727   unless (defined wantarray) {
1728     my @caller = caller;
1729     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
1730     return;
1731   }
1732
1733   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1734
1735   my $img = Imager->new();
1736
1737   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1738
1739   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1740   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1741
1742   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1743   return $img;
1744 }
1745
1746
1747 # Transform returns a spatial transformation of the input image
1748 # this moves pixels to a new location in the returned image.
1749 # NOTE - should make a utility function to check transforms for
1750 # stack overruns
1751
1752 sub transform {
1753   my $self=shift;
1754   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1755   my %opts=@_;
1756   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1757
1758 #  print Dumper(\%opts);
1759 #  xopcopdes
1760
1761   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1762     if (!$I2P) {
1763       eval ("use Affix::Infix2Postfix;");
1764       print $@;
1765       if ( $@ ) {
1766         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
1767         return undef;
1768       }
1769       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1770                                              {op=>'-',trans=>'Sub'},
1771                                              {op=>'*',trans=>'Mult'},
1772                                              {op=>'/',trans=>'Div'},
1773                                              {op=>'-','type'=>'unary',trans=>'u-'},
1774                                              {op=>'**'},
1775                                              {op=>'func','type'=>'unary'}],
1776                                      'grouping'=>[qw( \( \) )],
1777                                      'func'=>[qw( sin cos )],
1778                                      'vars'=>[qw( x y )]
1779                                     );
1780     }
1781
1782     @xt=$I2P->translate($opts{'xexpr'});
1783     @yt=$I2P->translate($opts{'yexpr'});
1784
1785     $numre=$I2P->{'numre'};
1786     @pt=(0,0);
1787
1788     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1789     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1790     @{$opts{'parm'}}=@pt;
1791   }
1792
1793 #  print Dumper(\%opts);
1794
1795   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1796     $self->{ERRSTR}='transform: no xopcodes given.';
1797     return undef;
1798   }
1799
1800   @op=@{$opts{'xopcodes'}};
1801   for $iop (@op) {
1802     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1803       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1804       return undef;
1805     }
1806     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1807   }
1808
1809
1810 # yopcopdes
1811
1812   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1813     $self->{ERRSTR}='transform: no yopcodes given.';
1814     return undef;
1815   }
1816
1817   @op=@{$opts{'yopcodes'}};
1818   for $iop (@op) {
1819     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1820       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1821       return undef;
1822     }
1823     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1824   }
1825
1826 #parameters
1827
1828   if ( !exists $opts{'parm'}) {
1829     $self->{ERRSTR}='transform: no parameter arg given.';
1830     return undef;
1831   }
1832
1833 #  print Dumper(\@ropx);
1834 #  print Dumper(\@ropy);
1835 #  print Dumper(\@ropy);
1836
1837   my $img = Imager->new();
1838   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1839   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1840   return $img;
1841 }
1842
1843
1844 sub transform2 {
1845   my ($opts, @imgs) = @_;
1846
1847   require "Imager/Expr.pm";
1848
1849   $opts->{variables} = [ qw(x y) ];
1850   my ($width, $height) = @{$opts}{qw(width height)};
1851   if (@imgs) {
1852     $width ||= $imgs[0]->getwidth();
1853     $height ||= $imgs[0]->getheight();
1854     my $img_num = 1;
1855     for my $img (@imgs) {
1856       $opts->{constants}{"w$img_num"} = $img->getwidth();
1857       $opts->{constants}{"h$img_num"} = $img->getheight();
1858       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1859       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1860       ++$img_num;
1861     }
1862   }
1863   if ($width) {
1864     $opts->{constants}{w} = $width;
1865     $opts->{constants}{cx} = $width/2;
1866   }
1867   else {
1868     $Imager::ERRSTR = "No width supplied";
1869     return;
1870   }
1871   if ($height) {
1872     $opts->{constants}{h} = $height;
1873     $opts->{constants}{cy} = $height/2;
1874   }
1875   else {
1876     $Imager::ERRSTR = "No height supplied";
1877     return;
1878   }
1879   my $code = Imager::Expr->new($opts);
1880   if (!$code) {
1881     $Imager::ERRSTR = Imager::Expr::error();
1882     return;
1883   }
1884   my $channels = $opts->{channels} || 3;
1885   unless ($channels >= 1 && $channels <= 4) {
1886     return Imager->_set_error("channels must be an integer between 1 and 4");
1887   }
1888
1889   my $img = Imager->new();
1890   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
1891                              $channels, $code->code(),
1892                              $code->nregs(), $code->cregs(),
1893                              [ map { $_->{IMG} } @imgs ]);
1894   if (!defined $img->{IMG}) {
1895     $Imager::ERRSTR = Imager->_error_as_msg();
1896     return;
1897   }
1898
1899   return $img;
1900 }
1901
1902 sub rubthrough {
1903   my $self=shift;
1904   my %opts=(tx => 0,ty => 0, @_);
1905
1906   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1907   unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1908
1909   %opts = (src_minx => 0,
1910            src_miny => 0,
1911            src_maxx => $opts{src}->getwidth(),
1912            src_maxy => $opts{src}->getheight(),
1913            %opts);
1914
1915   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx}, $opts{ty},
1916           $opts{src_minx}, $opts{src_miny}, $opts{src_maxx}, $opts{src_maxy})) {
1917     $self->{ERRSTR} = $self->_error_as_msg();
1918     return undef;
1919   }
1920   return $self;
1921 }
1922
1923
1924 sub flip {
1925   my $self  = shift;
1926   my %opts  = @_;
1927   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
1928   my $dir;
1929   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1930   $dir = $xlate{$opts{'dir'}};
1931   return $self if i_flipxy($self->{IMG}, $dir);
1932   return ();
1933 }
1934
1935 sub rotate {
1936   my $self = shift;
1937   my %opts = @_;
1938
1939   unless (defined wantarray) {
1940     my @caller = caller;
1941     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
1942     return;
1943   }
1944
1945   if (defined $opts{right}) {
1946     my $degrees = $opts{right};
1947     if ($degrees < 0) {
1948       $degrees += 360 * int(((-$degrees)+360)/360);
1949     }
1950     $degrees = $degrees % 360;
1951     if ($degrees == 0) {
1952       return $self->copy();
1953     }
1954     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1955       my $result = Imager->new();
1956       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1957         return $result;
1958       }
1959       else {
1960         $self->{ERRSTR} = $self->_error_as_msg();
1961         return undef;
1962       }
1963     }
1964     else {
1965       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1966       return undef;
1967     }
1968   }
1969   elsif (defined $opts{radians} || defined $opts{degrees}) {
1970     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1971
1972     my $result = Imager->new;
1973     if ($opts{back}) {
1974       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $opts{back});
1975     }
1976     else {
1977       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
1978     }
1979     if ($result->{IMG}) {
1980       return $result;
1981     }
1982     else {
1983       $self->{ERRSTR} = $self->_error_as_msg();
1984       return undef;
1985     }
1986   }
1987   else {
1988     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
1989     return undef;
1990   }
1991 }
1992
1993 sub matrix_transform {
1994   my $self = shift;
1995   my %opts = @_;
1996
1997   unless (defined wantarray) {
1998     my @caller = caller;
1999     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2000     return;
2001   }
2002
2003   if ($opts{matrix}) {
2004     my $xsize = $opts{xsize} || $self->getwidth;
2005     my $ysize = $opts{ysize} || $self->getheight;
2006
2007     my $result = Imager->new;
2008     if ($opts{back}) {
2009       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2010                                           $opts{matrix}, $opts{back})
2011         or return undef;
2012     }
2013     else {
2014       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2015                                           $opts{matrix})
2016         or return undef;
2017     }
2018
2019     return $result;
2020   }
2021   else {
2022     $self->{ERRSTR} = "matrix parameter required";
2023     return undef;
2024   }
2025 }
2026
2027 # blame Leolo :)
2028 *yatf = \&matrix_transform;
2029
2030 # These two are supported for legacy code only
2031
2032 sub i_color_new {
2033   return Imager::Color->new(@_);
2034 }
2035
2036 sub i_color_set {
2037   return Imager::Color::set(@_);
2038 }
2039
2040 # Draws a box between the specified corner points.
2041 sub box {
2042   my $self=shift;
2043   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2044   my $dflcl=i_color_new(255,255,255,255);
2045   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2046
2047   if (exists $opts{'box'}) {
2048     $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
2049     $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
2050     $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
2051     $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
2052   }
2053
2054   if ($opts{filled}) {
2055     my $color = _color($opts{'color'});
2056     unless ($color) {
2057       $self->{ERRSTR} = $Imager::ERRSTR;
2058       return;
2059     }
2060     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2061                  $opts{ymax}, $color);
2062   }
2063   elsif ($opts{fill}) {
2064     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2065       # assume it's a hash ref
2066       require 'Imager/Fill.pm';
2067       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2068         $self->{ERRSTR} = $Imager::ERRSTR;
2069         return undef;
2070       }
2071     }
2072     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2073                 $opts{ymax},$opts{fill}{fill});
2074   }
2075   else {
2076     my $color = _color($opts{'color'});
2077     unless ($color) {
2078       $self->{ERRSTR} = $Imager::ERRSTR;
2079       return;
2080     }
2081     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2082           $color);
2083   }
2084   return $self;
2085 }
2086
2087 # Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
2088
2089 sub arc {
2090   my $self=shift;
2091   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2092   my $dflcl=i_color_new(255,255,255,255);
2093   my %opts=(color=>$dflcl,
2094             'r'=>min($self->getwidth(),$self->getheight())/3,
2095             'x'=>$self->getwidth()/2,
2096             'y'=>$self->getheight()/2,
2097             'd1'=>0, 'd2'=>361, @_);
2098   if ($opts{fill}) {
2099     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2100       # assume it's a hash ref
2101       require 'Imager/Fill.pm';
2102       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2103         $self->{ERRSTR} = $Imager::ERRSTR;
2104         return;
2105       }
2106     }
2107     i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2108                 $opts{'d2'}, $opts{fill}{fill});
2109   }
2110   else {
2111     my $color = _color($opts{'color'});
2112     unless ($color) {
2113       $self->{ERRSTR} = $Imager::ERRSTR;
2114       return;
2115     }
2116     if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2117       i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2118                   $color);
2119     }
2120     else {
2121       if ($opts{'d1'} <= $opts{'d2'}) {
2122         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2123               $opts{'d1'}, $opts{'d2'}, $color);
2124       }
2125       else {
2126         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2127               $opts{'d1'}, 361,         $color);
2128         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2129               0,           $opts{'d2'}, $color);
2130       }
2131     }
2132   }
2133
2134   return $self;
2135 }
2136
2137 # Draws a line from one point to the other
2138 # the endpoint is set if the endp parameter is set which it is by default.
2139 # to turn of the endpoint being set use endp=>0 when calling line.
2140
2141 sub line {
2142   my $self=shift;
2143   my $dflcl=i_color_new(0,0,0,0);
2144   my %opts=(color=>$dflcl,
2145             endp => 1,
2146             @_);
2147   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2148
2149   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2150   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2151
2152   my $color = _color($opts{'color'});
2153   unless ($color) {
2154     $self->{ERRSTR} = $Imager::ERRSTR;
2155     return;
2156   }
2157
2158   $opts{antialias} = $opts{aa} if defined $opts{aa};
2159   if ($opts{antialias}) {
2160     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2161               $color, $opts{endp});
2162   } else {
2163     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2164            $color, $opts{endp});
2165   }
2166   return $self;
2167 }
2168
2169 # Draws a line between an ordered set of points - It more or less just transforms this
2170 # into a list of lines.
2171
2172 sub polyline {
2173   my $self=shift;
2174   my ($pt,$ls,@points);
2175   my $dflcl=i_color_new(0,0,0,0);
2176   my %opts=(color=>$dflcl,@_);
2177
2178   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2179
2180   if (exists($opts{points})) { @points=@{$opts{points}}; }
2181   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2182     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2183     }
2184
2185 #  print Dumper(\@points);
2186
2187   my $color = _color($opts{'color'});
2188   unless ($color) {
2189     $self->{ERRSTR} = $Imager::ERRSTR;
2190     return;
2191   }
2192   $opts{antialias} = $opts{aa} if defined $opts{aa};
2193   if ($opts{antialias}) {
2194     for $pt(@points) {
2195       if (defined($ls)) {
2196         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2197       }
2198       $ls=$pt;
2199     }
2200   } else {
2201     for $pt(@points) {
2202       if (defined($ls)) {
2203         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2204       }
2205       $ls=$pt;
2206     }
2207   }
2208   return $self;
2209 }
2210
2211 sub polygon {
2212   my $self = shift;
2213   my ($pt,$ls,@points);
2214   my $dflcl = i_color_new(0,0,0,0);
2215   my %opts = (color=>$dflcl, @_);
2216
2217   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2218
2219   if (exists($opts{points})) {
2220     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2221     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2222   }
2223
2224   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2225     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2226   }
2227
2228   if ($opts{'fill'}) {
2229     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2230       # assume it's a hash ref
2231       require 'Imager/Fill.pm';
2232       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2233         $self->{ERRSTR} = $Imager::ERRSTR;
2234         return undef;
2235       }
2236     }
2237     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2238                     $opts{'fill'}{'fill'});
2239   }
2240   else {
2241     my $color = _color($opts{'color'});
2242     unless ($color) {
2243       $self->{ERRSTR} = $Imager::ERRSTR;
2244       return;
2245     }
2246     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2247   }
2248
2249   return $self;
2250 }
2251
2252
2253 # this the multipoint bezier curve
2254 # this is here more for testing that actual usage since
2255 # this is not a good algorithm.  Usually the curve would be
2256 # broken into smaller segments and each done individually.
2257
2258 sub polybezier {
2259   my $self=shift;
2260   my ($pt,$ls,@points);
2261   my $dflcl=i_color_new(0,0,0,0);
2262   my %opts=(color=>$dflcl,@_);
2263
2264   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2265
2266   if (exists $opts{points}) {
2267     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2268     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2269   }
2270
2271   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2272     $self->{ERRSTR}='Missing or invalid points.';
2273     return;
2274   }
2275
2276   my $color = _color($opts{'color'});
2277   unless ($color) {
2278     $self->{ERRSTR} = $Imager::ERRSTR;
2279     return;
2280   }
2281   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2282   return $self;
2283 }
2284
2285 sub flood_fill {
2286   my $self = shift;
2287   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2288   my $rc;
2289
2290   unless (exists $opts{'x'} && exists $opts{'y'}) {
2291     $self->{ERRSTR} = "missing seed x and y parameters";
2292     return undef;
2293   }
2294
2295   if ($opts{fill}) {
2296     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2297       # assume it's a hash ref
2298       require 'Imager/Fill.pm';
2299       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2300         $self->{ERRSTR} = $Imager::ERRSTR;
2301         return;
2302       }
2303     }
2304     $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2305   }
2306   else {
2307     my $color = _color($opts{'color'});
2308     unless ($color) {
2309       $self->{ERRSTR} = $Imager::ERRSTR;
2310       return;
2311     }
2312     $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2313   }
2314   if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
2315 }
2316
2317 sub setpixel {
2318   my $self = shift;
2319
2320   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2321
2322   unless (exists $opts{'x'} && exists $opts{'y'}) {
2323     $self->{ERRSTR} = 'missing x and y parameters';
2324     return undef;
2325   }
2326
2327   my $x = $opts{'x'};
2328   my $y = $opts{'y'};
2329   my $color = _color($opts{color})
2330     or return undef;
2331   if (ref $x && ref $y) {
2332     unless (@$x == @$y) {
2333       $self->{ERRSTR} = 'length of x and y mismatch';
2334       return undef;
2335     }
2336     if ($color->isa('Imager::Color')) {
2337       for my $i (0..$#{$opts{'x'}}) {
2338         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2339       }
2340     }
2341     else {
2342       for my $i (0..$#{$opts{'x'}}) {
2343         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2344       }
2345     }
2346   }
2347   else {
2348     if ($color->isa('Imager::Color')) {
2349       i_ppix($self->{IMG}, $x, $y, $color);
2350     }
2351     else {
2352       i_ppixf($self->{IMG}, $x, $y, $color);
2353     }
2354   }
2355
2356   $self;
2357 }
2358
2359 sub getpixel {
2360   my $self = shift;
2361
2362   my %opts = ( "type"=>'8bit', @_);
2363
2364   unless (exists $opts{'x'} && exists $opts{'y'}) {
2365     $self->{ERRSTR} = 'missing x and y parameters';
2366     return undef;
2367   }
2368
2369   my $x = $opts{'x'};
2370   my $y = $opts{'y'};
2371   if (ref $x && ref $y) {
2372     unless (@$x == @$y) {
2373       $self->{ERRSTR} = 'length of x and y mismatch';
2374       return undef;
2375     }
2376     my @result;
2377     if ($opts{"type"} eq '8bit') {
2378       for my $i (0..$#{$opts{'x'}}) {
2379         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2380       }
2381     }
2382     else {
2383       for my $i (0..$#{$opts{'x'}}) {
2384         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2385       }
2386     }
2387     return wantarray ? @result : \@result;
2388   }
2389   else {
2390     if ($opts{"type"} eq '8bit') {
2391       return i_get_pixel($self->{IMG}, $x, $y);
2392     }
2393     else {
2394       return i_gpixf($self->{IMG}, $x, $y);
2395     }
2396   }
2397
2398   $self;
2399 }
2400
2401 sub getscanline {
2402   my $self = shift;
2403   my %opts = ( type => '8bit', x=>0, @_);
2404
2405   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2406
2407   unless (defined $opts{'y'}) {
2408     $self->_set_error("missing y parameter");
2409     return;
2410   }
2411
2412   if ($opts{type} eq '8bit') {
2413     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2414                   $opts{y});
2415   }
2416   elsif ($opts{type} eq 'float') {
2417     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2418                   $opts{y});
2419   }
2420   else {
2421     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2422     return;
2423   }
2424 }
2425
2426 sub setscanline {
2427   my $self = shift;
2428   my %opts = ( x=>0, @_);
2429
2430   unless (defined $opts{'y'}) {
2431     $self->_set_error("missing y parameter");
2432     return;
2433   }
2434
2435   if (!$opts{type}) {
2436     if (ref $opts{pixels} && @{$opts{pixels}}) {
2437       # try to guess the type
2438       if ($opts{pixels}[0]->isa('Imager::Color')) {
2439         $opts{type} = '8bit';
2440       }
2441       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
2442         $opts{type} = 'float';
2443       }
2444       else {
2445         $self->_set_error("missing type parameter and could not guess from pixels");
2446         return;
2447       }
2448     }
2449     else {
2450       # default
2451       $opts{type} = '8bit';
2452     }
2453   }
2454
2455   if ($opts{type} eq '8bit') {
2456     if (ref $opts{pixels}) {
2457       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2458     }
2459     else {
2460       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2461     }
2462   }
2463   elsif ($opts{type} eq 'float') {
2464     if (ref $opts{pixels}) {
2465       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2466     }
2467     else {
2468       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2469     }
2470   }
2471   else {
2472     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2473     return;
2474   }
2475 }
2476
2477 sub getsamples {
2478   my $self = shift;
2479   my %opts = ( type => '8bit', x=>0, @_);
2480
2481   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2482
2483   unless (defined $opts{'y'}) {
2484     $self->_set_error("missing y parameter");
2485     return;
2486   }
2487
2488   unless ($opts{channels}) {
2489     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
2490   }
2491
2492   if ($opts{type} eq '8bit') {
2493     return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2494                    $opts{y}, @{$opts{channels}});
2495   }
2496   elsif ($opts{type} eq 'float') {
2497     return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2498                     $opts{y}, @{$opts{channels}});
2499   }
2500   else {
2501     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2502     return;
2503   }
2504 }
2505
2506 # make an identity matrix of the given size
2507 sub _identity {
2508   my ($size) = @_;
2509
2510   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2511   for my $c (0 .. ($size-1)) {
2512     $matrix->[$c][$c] = 1;
2513   }
2514   return $matrix;
2515 }
2516
2517 # general function to convert an image
2518 sub convert {
2519   my ($self, %opts) = @_;
2520   my $matrix;
2521
2522   unless (defined wantarray) {
2523     my @caller = caller;
2524     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
2525     return;
2526   }
2527
2528   # the user can either specify a matrix or preset
2529   # the matrix overrides the preset
2530   if (!exists($opts{matrix})) {
2531     unless (exists($opts{preset})) {
2532       $self->{ERRSTR} = "convert() needs a matrix or preset";
2533       return;
2534     }
2535     else {
2536       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2537         # convert to greyscale, keeping the alpha channel if any
2538         if ($self->getchannels == 3) {
2539           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2540         }
2541         elsif ($self->getchannels == 4) {
2542           # preserve the alpha channel
2543           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2544                       [ 0,     0,     0,     1 ] ];
2545         }
2546         else {
2547           # an identity
2548           $matrix = _identity($self->getchannels);
2549         }
2550       }
2551       elsif ($opts{preset} eq 'noalpha') {
2552         # strip the alpha channel
2553         if ($self->getchannels == 2 or $self->getchannels == 4) {
2554           $matrix = _identity($self->getchannels);
2555           pop(@$matrix); # lose the alpha entry
2556         }
2557         else {
2558           $matrix = _identity($self->getchannels);
2559         }
2560       }
2561       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2562         # extract channel 0
2563         $matrix = [ [ 1 ] ];
2564       }
2565       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2566         $matrix = [ [ 0, 1 ] ];
2567       }
2568       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2569         $matrix = [ [ 0, 0, 1 ] ];
2570       }
2571       elsif ($opts{preset} eq 'alpha') {
2572         if ($self->getchannels == 2 or $self->getchannels == 4) {
2573           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2574         }
2575         else {
2576           # the alpha is just 1 <shrug>
2577           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2578         }
2579       }
2580       elsif ($opts{preset} eq 'rgb') {
2581         if ($self->getchannels == 1) {
2582           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2583         }
2584         elsif ($self->getchannels == 2) {
2585           # preserve the alpha channel
2586           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2587         }
2588         else {
2589           $matrix = _identity($self->getchannels);
2590         }
2591       }
2592       elsif ($opts{preset} eq 'addalpha') {
2593         if ($self->getchannels == 1) {
2594           $matrix = _identity(2);
2595         }
2596         elsif ($self->getchannels == 3) {
2597           $matrix = _identity(4);
2598         }
2599         else {
2600           $matrix = _identity($self->getchannels);
2601         }
2602       }
2603       else {
2604         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2605         return undef;
2606       }
2607     }
2608   }
2609   else {
2610     $matrix = $opts{matrix};
2611   }
2612
2613   my $new = Imager->new();
2614   $new->{IMG} = i_img_new();
2615   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2616     # most likely a bad matrix
2617     $self->{ERRSTR} = _error_as_msg();
2618     return undef;
2619   }
2620   return $new;
2621 }
2622
2623
2624 # general function to map an image through lookup tables
2625
2626 sub map {
2627   my ($self, %opts) = @_;
2628   my @chlist = qw( red green blue alpha );
2629
2630   if (!exists($opts{'maps'})) {
2631     # make maps from channel maps
2632     my $chnum;
2633     for $chnum (0..$#chlist) {
2634       if (exists $opts{$chlist[$chnum]}) {
2635         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2636       } elsif (exists $opts{'all'}) {
2637         $opts{'maps'}[$chnum] = $opts{'all'};
2638       }
2639     }
2640   }
2641   if ($opts{'maps'} and $self->{IMG}) {
2642     i_map($self->{IMG}, $opts{'maps'} );
2643   }
2644   return $self;
2645 }
2646
2647 sub difference {
2648   my ($self, %opts) = @_;
2649
2650   defined $opts{mindist} or $opts{mindist} = 0;
2651
2652   defined $opts{other}
2653     or return $self->_set_error("No 'other' parameter supplied");
2654   defined $opts{other}{IMG}
2655     or return $self->_set_error("No image data in 'other' image");
2656
2657   $self->{IMG}
2658     or return $self->_set_error("No image data");
2659
2660   my $result = Imager->new;
2661   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
2662                                 $opts{mindist})
2663     or return $self->_set_error($self->_error_as_msg());
2664
2665   return $result;
2666 }
2667
2668 # destructive border - image is shrunk by one pixel all around
2669
2670 sub border {
2671   my ($self,%opts)=@_;
2672   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2673   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2674 }
2675
2676
2677 # Get the width of an image
2678
2679 sub getwidth {
2680   my $self = shift;
2681   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2682   return (i_img_info($self->{IMG}))[0];
2683 }
2684
2685 # Get the height of an image
2686
2687 sub getheight {
2688   my $self = shift;
2689   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2690   return (i_img_info($self->{IMG}))[1];
2691 }
2692
2693 # Get number of channels in an image
2694
2695 sub getchannels {
2696   my $self = shift;
2697   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2698   return i_img_getchannels($self->{IMG});
2699 }
2700
2701 # Get channel mask
2702
2703 sub getmask {
2704   my $self = shift;
2705   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2706   return i_img_getmask($self->{IMG});
2707 }
2708
2709 # Set channel mask
2710
2711 sub setmask {
2712   my $self = shift;
2713   my %opts = @_;
2714   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2715   i_img_setmask( $self->{IMG} , $opts{mask} );
2716 }
2717
2718 # Get number of colors in an image
2719
2720 sub getcolorcount {
2721   my $self=shift;
2722   my %opts=('maxcolors'=>2**30,@_);
2723   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2724   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2725   return ($rc==-1? undef : $rc);
2726 }
2727
2728 # draw string to an image
2729
2730 sub string {
2731   my $self = shift;
2732   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2733
2734   my %input=('x'=>0, 'y'=>0, @_);
2735   $input{string}||=$input{text};
2736
2737   unless(exists $input{string}) {
2738     $self->{ERRSTR}="missing required parameter 'string'";
2739     return;
2740   }
2741
2742   unless($input{font}) {
2743     $self->{ERRSTR}="missing required parameter 'font'";
2744     return;
2745   }
2746
2747   unless ($input{font}->draw(image=>$self, %input)) {
2748     $self->{ERRSTR} = $self->_error_as_msg();
2749     return;
2750   }
2751
2752   return $self;
2753 }
2754
2755 my @file_limit_names = qw/width height bytes/;
2756
2757 sub set_file_limits {
2758   shift;
2759
2760   my %opts = @_;
2761   my %values;
2762
2763   if ($opts{reset}) {
2764     @values{@file_limit_names} = (0) x @file_limit_names;
2765   }
2766   else {
2767     @values{@file_limit_names} = i_get_image_file_limits();
2768   }
2769
2770   for my $key (keys %values) {
2771     defined $opts{$key} and $values{$key} = $opts{$key};
2772   }
2773
2774   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
2775 }
2776
2777 sub get_file_limits {
2778   i_get_image_file_limits();
2779 }
2780
2781 # Shortcuts that can be exported
2782
2783 sub newcolor { Imager::Color->new(@_); }
2784 sub newfont  { Imager::Font->new(@_); }
2785
2786 *NC=*newcolour=*newcolor;
2787 *NF=*newfont;
2788
2789 *open=\&read;
2790 *circle=\&arc;
2791
2792
2793 #### Utility routines
2794
2795 sub errstr {
2796   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2797 }
2798
2799 sub _set_error {
2800   my ($self, $msg) = @_;
2801
2802   if (ref $self) {
2803     $self->{ERRSTR} = $msg;
2804   }
2805   else {
2806     $ERRSTR = $msg;
2807   }
2808   return;
2809 }
2810
2811 # Default guess for the type of an image from extension
2812
2813 sub def_guess_type {
2814   my $name=lc(shift);
2815   my $ext;
2816   $ext=($name =~ m/\.([^\.]+)$/)[0];
2817   return 'tiff' if ($ext =~ m/^tiff?$/);
2818   return 'jpeg' if ($ext =~ m/^jpe?g$/);
2819   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
2820   return 'png'  if ($ext eq "png");
2821   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
2822   return 'tga'  if ($ext eq "tga");
2823   return 'rgb'  if ($ext eq "rgb");
2824   return 'gif'  if ($ext eq "gif");
2825   return 'raw'  if ($ext eq "raw");
2826   return ();
2827 }
2828
2829 # get the minimum of a list
2830
2831 sub min {
2832   my $mx=shift;
2833   for(@_) { if ($_<$mx) { $mx=$_; }}
2834   return $mx;
2835 }
2836
2837 # get the maximum of a list
2838
2839 sub max {
2840   my $mx=shift;
2841   for(@_) { if ($_>$mx) { $mx=$_; }}
2842   return $mx;
2843 }
2844
2845 # string stuff for iptc headers
2846
2847 sub clean {
2848   my($str)=$_[0];
2849   $str = substr($str,3);
2850   $str =~ s/[\n\r]//g;
2851   $str =~ s/\s+/ /g;
2852   $str =~ s/^\s//;
2853   $str =~ s/\s$//;
2854   return $str;
2855 }
2856
2857 # A little hack to parse iptc headers.
2858
2859 sub parseiptc {
2860   my $self=shift;
2861   my(@sar,$item,@ar);
2862   my($caption,$photogr,$headln,$credit);
2863
2864   my $str=$self->{IPTCRAW};
2865
2866   #print $str;
2867
2868   @ar=split(/8BIM/,$str);
2869
2870   my $i=0;
2871   foreach (@ar) {
2872     if (/^\004\004/) {
2873       @sar=split(/\034\002/);
2874       foreach $item (@sar) {
2875         if ($item =~ m/^x/) {
2876           $caption=&clean($item);
2877           $i++;
2878         }
2879         if ($item =~ m/^P/) {
2880           $photogr=&clean($item);
2881           $i++;
2882         }
2883         if ($item =~ m/^i/) {
2884           $headln=&clean($item);
2885           $i++;
2886         }
2887         if ($item =~ m/^n/) {
2888           $credit=&clean($item);
2889           $i++;
2890         }
2891       }
2892     }
2893   }
2894   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2895 }
2896
2897 # Autoload methods go after =cut, and are processed by the autosplit program.
2898
2899 1;
2900 __END__
2901 # Below is the stub of documentation for your module. You better edit it!
2902
2903 =head1 NAME
2904
2905 Imager - Perl extension for Generating 24 bit Images
2906
2907 =head1 SYNOPSIS
2908
2909   # Thumbnail example
2910
2911   #!/usr/bin/perl -w
2912   use strict;
2913   use Imager;
2914
2915   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2916   my $file = shift;
2917
2918   my $format;
2919
2920   my $img = Imager->new();
2921   # see Imager::Files for information on the read() method
2922   $img->read(file=>$file) or die $img->errstr();
2923
2924   $file =~ s/\.[^.]*$//;
2925
2926   # Create smaller version
2927   # documented in Imager::Transformations
2928   my $thumb = $img->scale(scalefactor=>.3);
2929
2930   # Autostretch individual channels
2931   $thumb->filter(type=>'autolevels');
2932
2933   # try to save in one of these formats
2934   SAVE:
2935
2936   for $format ( qw( png gif jpg tiff ppm ) ) {
2937     # Check if given format is supported
2938     if ($Imager::formats{$format}) {
2939       $file.="_low.$format";
2940       print "Storing image as: $file\n";
2941       # documented in Imager::Files
2942       $thumb->write(file=>$file) or
2943         die $thumb->errstr;
2944       last SAVE;
2945     }
2946   }
2947
2948 =head1 DESCRIPTION
2949
2950 Imager is a module for creating and altering images.  It can read and
2951 write various image formats, draw primitive shapes like lines,and
2952 polygons, blend multiple images together in various ways, scale, crop,
2953 render text and more.
2954
2955 =head2 Overview of documentation
2956
2957 =over
2958
2959 =item *
2960
2961 Imager - This document - Synopsis Example, Table of Contents and
2962 Overview.
2963
2964 =item *
2965
2966 L<Imager::Tutorial> - a brief introduction to Imager.
2967
2968 =item *
2969
2970 L<Imager::Cookbook> - how to do various things with Imager.
2971
2972 =item *
2973
2974 L<Imager::ImageTypes> - Basics of constructing image objects with
2975 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
2976 8/16/double bits/channel, color maps, channel masks, image tags, color
2977 quantization.  Also discusses basic image information methods.
2978
2979 =item *
2980
2981 L<Imager::Files> - IO interaction, reading/writing images, format
2982 specific tags.
2983
2984 =item *
2985
2986 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
2987 flood fill.
2988
2989 =item *
2990
2991 L<Imager::Color> - Color specification.
2992
2993 =item *
2994
2995 L<Imager::Fill> - Fill pattern specification.
2996
2997 =item *
2998
2999 L<Imager::Font> - General font rendering, bounding boxes and font
3000 metrics.
3001
3002 =item *
3003
3004 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
3005 blending, pasting, convert and map.
3006
3007 =item *
3008
3009 L<Imager::Engines> - Programmable transformations through
3010 C<transform()>, C<transform2()> and C<matrix_transform()>.
3011
3012 =item *
3013
3014 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
3015 filter plugins.
3016
3017 =item *
3018
3019 L<Imager::Expr> - Expressions for evaluation engine used by
3020 transform2().
3021
3022 =item *
3023
3024 L<Imager::Matrix2d> - Helper class for affine transformations.
3025
3026 =item *
3027
3028 L<Imager::Fountain> - Helper for making gradient profiles.
3029
3030 =back
3031
3032 =head2 Basic Overview
3033
3034 An Image object is created with C<$img = Imager-E<gt>new()>.
3035 Examples:
3036
3037   $img=Imager->new();                         # create empty image
3038   $img->read(file=>'lena.png',type=>'png') or # read image from file
3039      die $img->errstr();                      # give an explanation
3040                                               # if something failed
3041
3042 or if you want to create an empty image:
3043
3044   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3045
3046 This example creates a completely black image of width 400 and height
3047 300 and 4 channels.
3048
3049 When an operation fails which can be directly associated with an image
3050 the error message is stored can be retrieved with
3051 C<$img-E<gt>errstr()>.
3052
3053 In cases where no image object is associated with an operation
3054 C<$Imager::ERRSTR> is used to report errors not directly associated
3055 with an image object.  You can also call C<Imager->errstr> to get this
3056 value.
3057
3058 The C<Imager-E<gt>new> method is described in detail in
3059 L<Imager::ImageTypes>.
3060
3061 =head1 METHOD INDEX
3062
3063 Where to find information on methods for Imager class objects.
3064
3065 addcolors() -  L<Imager::ImageTypes>
3066
3067 addtag() -  L<Imager::ImageTypes> - add image tags
3068
3069 arc() - L<Imager::Draw/arc>
3070
3071 bits() - L<Imager::ImageTypes> - number of bits per sample for the
3072 image
3073
3074 box() - L<Imager::Draw/box>
3075
3076 circle() - L<Imager::Draw/circle>
3077
3078 colorcount() - L<Imager::Draw/colorcount>
3079
3080 convert() - L<Imager::Transformations/"Color transformations"> -
3081 transform the color space
3082
3083 copy() - L<Imager::Transformations/copy>
3084
3085 crop() - L<Imager::Transformations/crop> - extract part of an image
3086
3087 deltag() -  L<Imager::ImageTypes> - delete image tags
3088
3089 difference() - L<Imager::Filters/"Image Difference">
3090
3091 errstr() - L<Imager/"Basic Overview">
3092
3093 filter() - L<Imager::Filters>
3094
3095 findcolor() - L<Imager::ImageTypes> - search the image palette, if it
3096 has one
3097
3098 flip() - L<Imager::Transformations/flip>
3099
3100 flood_fill() - L<Imager::Draw/flood_fill>
3101
3102 getchannels() -  L<Imager::ImageTypes>
3103
3104 getcolorcount() -  L<Imager::ImageTypes>
3105
3106 getcolors() - L<Imager::ImageTypes> - get colors from the image
3107 palette, if it has one
3108
3109 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3110
3111 getheight() - L<Imager::ImageTypes>
3112
3113 getpixel() - L<Imager::Draw/setpixel and getpixel>
3114
3115 getsamples() - L<Imager::Draw/getsamples>
3116
3117 getscanline() - L<Imager::Draw/getscanline>
3118
3119 getwidth() - L<Imager::ImageTypes>
3120
3121 img_set() - L<Imager::ImageTypes>
3122
3123 line() - L<Imager::Draw/line>
3124
3125 map() - L<Imager::Transformations/"Color Mappings"> - remap color
3126 channel values
3127
3128 masked() -  L<Imager::ImageTypes> - make a masked image
3129
3130 matrix_transform() - L<Imager::Engines/"Matrix Transformations">
3131
3132 maxcolors() - L<Imager::ImageTypes/maxcolor>
3133
3134 new() - L<Imager::ImageTypes>
3135
3136 open() - L<Imager::Files> - an alias for read()
3137
3138 paste() - L<Imager::Transformations/paste> - draw an image onto an image
3139
3140 polygon() - L<Imager::Draw/polygon>
3141
3142 polyline() - L<Imager::Draw/polyline>
3143
3144 read() - L<Imager::Files> - read a single image from an image file
3145
3146 read_multi() - L<Imager::Files> - read multiple images from an image
3147 file
3148
3149 rotate() - L<Imager::Transformations/rotate>
3150
3151 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
3152 image and use the alpha channel
3153
3154 scale() - L<Imager::Transformations/scale>
3155
3156 setscanline() - L<Imager::Draw/setscanline>
3157
3158 scaleX() - L<Imager::Transformations/scaleX>
3159
3160 scaleY() - L<Imager::Transformations/scaleY>
3161
3162 setcolors() - L<Imager::ImageTypes> - set palette colors in a paletted image
3163
3164 setpixel() - L<Imager::Draw/setpixel and getpixel>
3165
3166 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3167
3168 string() - L<Imager::Font/string> - draw text on an image
3169
3170 tags() -  L<Imager::ImageTypes> - fetch image tags
3171
3172 to_paletted() -  L<Imager::ImageTypes>
3173
3174 to_rgb8() - L<Imager::ImageTypes>
3175
3176 transform() - L<Imager::Engines/"transform">
3177
3178 transform2() - L<Imager::Engines/"transform2">
3179
3180 type() -  L<Imager::ImageTypes> - type of image (direct vs paletted)
3181
3182 virtual() - L<Imager::ImageTypes> - whether the image has it's own
3183 data
3184
3185 write() - L<Imager::Files> - write an image to a file
3186
3187 write_multi() - L<Imager::Files> - write multiple image to an image
3188 file.
3189
3190 =head1 CONCEPT INDEX
3191
3192 animated GIF - L<Imager::File/"Writing an animated GIF">
3193
3194 aspect ratio - L<Imager::ImageTypes/i_xres>,
3195 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
3196
3197 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
3198
3199 boxes, drawing - L<Imager::Draw/box>
3200
3201 color - L<Imager::Color>
3202
3203 color names - L<Imager::Color>, L<Imager::Color::Table>
3204
3205 combine modes - L<Imager::Fill/combine>
3206
3207 contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
3208
3209 convolution - L<Imager::Filter/conv>
3210
3211 cropping - L<Imager::Transformations/crop>
3212
3213 dpi - L<Imager::ImageTypes/i_xres>
3214
3215 drawing boxes - L<Imager::Draw/box>
3216
3217 drawing lines - L<Imager::Draw/line>
3218
3219 drawing text - L<Imager::Font/string>, L<Imager::Font/align>
3220
3221 error message - L<Imager/"Basic Overview">
3222
3223 files, font - L<Imager::Font>
3224
3225 files, image - L<Imager::Files>
3226
3227 filling, types of fill - L<Imager::Fill>
3228
3229 filling, boxes - L<Imager::Draw/box>
3230
3231 filling, flood fill - L<Imager::Draw/flood_fill>
3232
3233 flood fill - L<Imager::Draw/flood_fill>
3234
3235 fonts - L<Imager::Font>
3236
3237 fonts, drawing with - L<Imager::Font/string>, L<Imager::Font/align>,
3238 L<Imager::Font::Wrap>
3239
3240 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3241
3242 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
3243
3244 fountain fill - L<Imager::Fill/"Fountain fills">,
3245 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3246 L<Imager::Filters/gradgen>
3247
3248 GIF files - L<Imager::Files/"GIF">
3249
3250 GIF files, animated - L<Imager::File/"Writing an animated GIF">
3251
3252 gradient fill - L<Imager::Fill/"Fountain fills">,
3253 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3254 L<Imager::Filters/gradgen>
3255
3256 guassian blur - L<Imager::Filter/guassian>
3257
3258 hatch fills - L<Imager::Fill/"Hatched fills">
3259
3260 invert image - L<Imager::Filter/hardinvert>
3261
3262 JPEG - L<Imager::Files/"JPEG">
3263
3264 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
3265
3266 lines, drawing - L<Imager::Draw/line>
3267
3268 matrix - L<Imager::Matrix2d>,
3269 L<Imager::Transformations/"Matrix Transformations">,
3270 L<Imager::Font/transform>
3271
3272 metadata, image - L<Imager::ImageTypes/"Tags">
3273
3274 mosaic - L<Imager::Filter/mosaic>
3275
3276 noise, filter - L<Imager::Filter/noise>
3277
3278 noise, rendered - L<Imager::Filter/turbnoise>,
3279 L<Imager::Filter/radnoise>
3280
3281 posterize - L<Imager::Filter/postlevels>
3282
3283 png files - L<Imager::Files>, L<Imager::Files/"PNG">
3284
3285 pnm - L<Imager::Files/"PNM (Portable aNy Map)">
3286
3287 rectangles, drawing - L<Imager::Draw/box>
3288
3289 resizing an image - L<Imager::Transformations/scale>,
3290 L<Imager::Transformations/crop>
3291
3292 saving an image - L<Imager::Files>
3293
3294 scaling - L<Imager::Transformations/scale>
3295
3296 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
3297
3298 size, image - L<Imager::ImageTypes/getwidth>,
3299 L<Imager::ImageTypes/getheight>
3300
3301 size, text - L<Imager::Font/bounding_box>
3302
3303 text, drawing - L<Imager::Font/string>, L<Imager::Font/align>,
3304 L<Imager::Font::Wrap>
3305
3306 text, wrapping text in an area - L<Imager::Font::Wrap>
3307
3308 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3309
3310 tiles, color - L<Imager::Filter/mosaic>
3311
3312 unsharp mask - L<Imager::Filter/unsharpmask>
3313
3314 watermark - L<Imager::Filter/watermark>
3315
3316 writing an image - L<Imager::Files>
3317
3318 =head1 SUPPORT
3319
3320 You can ask for help, report bugs or express your undying love for
3321 Imager on the Imager-devel mailing list.
3322
3323 To subscribe send a message with C<subscribe> in the body to:
3324
3325    imager-devel+request@molar.is
3326
3327 or use the form at:
3328
3329    http://www.molar.is/en/lists/imager-devel/
3330    (annonymous is temporarily off due to spam)
3331
3332 where you can also find the mailing list archive.
3333
3334 If you're into IRC, you can typically find the developers in #Imager
3335 on irc.perl.org.  As with any IRC channel, the participants could be
3336 occupied or asleep, so please be patient.
3337
3338 You can report bugs by pointing your browser at:
3339
3340   https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager
3341
3342 Please remember to include the versions of Imager, perl, supporting
3343 libraries, and any relevant code.  If you have specific images that
3344 cause the problems, please include those too.
3345
3346 =head1 BUGS
3347
3348 Bugs are listed individually for relevant pod pages.
3349
3350 =head1 AUTHOR
3351
3352 Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
3353 (tony@imager.perl.org) See the README for a complete list.
3354
3355 =head1 SEE ALSO
3356
3357 perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
3358 Imager::Color(3), Imager::Fill(3), Imager::Font(3),
3359 Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
3360 Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
3361
3362 Affix::Infix2Postfix(3), Parse::RecDescent(3)
3363 http://imager.perl.org/
3364
3365 =cut