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     $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1153     if ( !defined($self->{IMG}) ) {
1154       $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1155     }
1156     $self->{DEBUG} && print "loading a tiff file\n";
1157     return $self;
1158   }
1159
1160   if ( $input{'type'} eq 'pnm' ) {
1161     $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1162     if ( !defined($self->{IMG}) ) {
1163       $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
1164     }
1165     $self->{DEBUG} && print "loading a pnm file\n";
1166     return $self;
1167   }
1168
1169   if ( $input{'type'} eq 'png' ) {
1170     $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1171     if ( !defined($self->{IMG}) ) {
1172       $self->{ERRSTR} = $self->_error_as_msg();
1173       return undef;
1174     }
1175     $self->{DEBUG} && print "loading a png file\n";
1176   }
1177
1178   if ( $input{'type'} eq 'bmp' ) {
1179     $self->{IMG}=i_readbmp_wiol( $IO );
1180     if ( !defined($self->{IMG}) ) {
1181       $self->{ERRSTR}=$self->_error_as_msg();
1182       return undef;
1183     }
1184     $self->{DEBUG} && print "loading a bmp file\n";
1185   }
1186
1187   if ( $input{'type'} eq 'gif' ) {
1188     if ($input{colors} && !ref($input{colors})) {
1189       # must be a reference to a scalar that accepts the colour map
1190       $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1191       return undef;
1192     }
1193     if ($input{colors}) {
1194       my $colors;
1195       ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1196       if ($colors) {
1197         ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1198       }
1199     }
1200     else {
1201       $self->{IMG} =i_readgif_wiol( $IO );
1202     }
1203     if ( !defined($self->{IMG}) ) {
1204       $self->{ERRSTR}=$self->_error_as_msg();
1205       return undef;
1206     }
1207     $self->{DEBUG} && print "loading a gif file\n";
1208   }
1209
1210   if ( $input{'type'} eq 'tga' ) {
1211     $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1212     if ( !defined($self->{IMG}) ) {
1213       $self->{ERRSTR}=$self->_error_as_msg();
1214       return undef;
1215     }
1216     $self->{DEBUG} && print "loading a tga file\n";
1217   }
1218
1219   if ( $input{'type'} eq 'rgb' ) {
1220     $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1221     if ( !defined($self->{IMG}) ) {
1222       $self->{ERRSTR}=$self->_error_as_msg();
1223       return undef;
1224     }
1225     $self->{DEBUG} && print "loading a tga file\n";
1226   }
1227
1228
1229   if ( $input{'type'} eq 'raw' ) {
1230     my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1231
1232     if ( !($params{xsize} && $params{ysize}) ) {
1233       $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1234       return undef;
1235     }
1236
1237     $self->{IMG} = i_readraw_wiol( $IO,
1238                                    $params{xsize},
1239                                    $params{ysize},
1240                                    $params{datachannels},
1241                                    $params{storechannels},
1242                                    $params{interleave});
1243     if ( !defined($self->{IMG}) ) {
1244       $self->{ERRSTR}='unable to read raw image';
1245       return undef;
1246     }
1247     $self->{DEBUG} && print "loading a raw file\n";
1248   }
1249
1250   return $self;
1251 }
1252
1253 sub _fix_gif_positions {
1254   my ($opts, $opt, $msg, @imgs) = @_;
1255
1256   my $positions = $opts->{'gif_positions'};
1257   my $index = 0;
1258   for my $pos (@$positions) {
1259     my ($x, $y) = @$pos;
1260     my $img = $imgs[$index++];
1261     $img->settag(name=>'gif_left', value=>$x);
1262     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1263   }
1264   $$msg .= "replaced with the gif_left and gif_top tags";
1265 }
1266
1267 my %obsolete_opts =
1268   (
1269    gif_each_palette=>'gif_local_map',
1270    interlace       => 'gif_interlace',
1271    gif_delays => 'gif_delay',
1272    gif_positions => \&_fix_gif_positions,
1273    gif_loop_count => 'gif_loop',
1274   );
1275
1276 sub _set_opts {
1277   my ($self, $opts, $prefix, @imgs) = @_;
1278
1279   for my $opt (keys %$opts) {
1280     my $tagname = $opt;
1281     if ($obsolete_opts{$opt}) {
1282       my $new = $obsolete_opts{$opt};
1283       my $msg = "Obsolete option $opt ";
1284       if (ref $new) {
1285         $new->($opts, $opt, \$msg, @imgs);
1286       }
1287       else {
1288         $msg .= "replaced with the $new tag ";
1289         $tagname = $new;
1290       }
1291       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1292       warn $msg if $warn_obsolete && $^W;
1293     }
1294     next unless $tagname =~ /^\Q$prefix/;
1295     my $value = $opts->{$opt};
1296     if (ref $value) {
1297       if (UNIVERSAL::isa($value, "Imager::Color")) {
1298         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1299         for my $img (@imgs) {
1300           $img->settag(name=>$tagname, value=>$tag);
1301         }
1302       }
1303       elsif (ref($value) eq 'ARRAY') {
1304         for my $i (0..$#$value) {
1305           my $val = $value->[$i];
1306           if (ref $val) {
1307             if (UNIVERSAL::isa($val, "Imager::Color")) {
1308               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1309               $i < @imgs and
1310                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1311             }
1312             else {
1313               $self->_set_error("Unknown reference type " . ref($value) .
1314                                 " supplied in array for $opt");
1315               return;
1316             }
1317           }
1318           else {
1319             $i < @imgs
1320               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1321           }
1322         }
1323       }
1324       else {
1325         $self->_set_error("Unknown reference type " . ref($value) .
1326                           " supplied for $opt");
1327         return;
1328       }
1329     }
1330     else {
1331       # set it as a tag for every image
1332       for my $img (@imgs) {
1333         $img->settag(name=>$tagname, value=>$value);
1334       }
1335     }
1336   }
1337
1338   return 1;
1339 }
1340
1341 # Write an image to file
1342 sub write {
1343   my $self = shift;
1344   my %input=(jpegquality=>75,
1345              gifquant=>'mc',
1346              lmdither=>6.0,
1347              lmfixed=>[],
1348              idstring=>"",
1349              compress=>1,
1350              wierdpack=>0,
1351              fax_fine=>1, @_);
1352   my $rc;
1353
1354   $self->_set_opts(\%input, "i_", $self)
1355     or return undef;
1356
1357   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1358
1359   if (!$input{'type'} and $input{file}) {
1360     $input{'type'}=$FORMATGUESS->($input{file});
1361   }
1362   if (!$input{'type'}) {
1363     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1364     return undef;
1365   }
1366
1367   if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
1368
1369   my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1370     or return undef;
1371
1372   if ($input{'type'} eq 'tiff') {
1373     $self->_set_opts(\%input, "tiff_", $self)
1374       or return undef;
1375     $self->_set_opts(\%input, "exif_", $self)
1376       or return undef;
1377
1378     if (defined $input{class} && $input{class} eq 'fax') {
1379       if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1380         $self->{ERRSTR}='Could not write to buffer';
1381         return undef;
1382       }
1383     } else {
1384       if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1385         $self->{ERRSTR}='Could not write to buffer';
1386         return undef;
1387       }
1388     }
1389   } elsif ( $input{'type'} eq 'pnm' ) {
1390     $self->_set_opts(\%input, "pnm_", $self)
1391       or return undef;
1392     if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1393       $self->{ERRSTR}='unable to write pnm image';
1394       return undef;
1395     }
1396     $self->{DEBUG} && print "writing a pnm file\n";
1397   } elsif ( $input{'type'} eq 'raw' ) {
1398     $self->_set_opts(\%input, "raw_", $self)
1399       or return undef;
1400     if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1401       $self->{ERRSTR}='unable to write raw image';
1402       return undef;
1403     }
1404     $self->{DEBUG} && print "writing a raw file\n";
1405   } elsif ( $input{'type'} eq 'png' ) {
1406     $self->_set_opts(\%input, "png_", $self)
1407       or return undef;
1408     if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1409       $self->{ERRSTR}='unable to write png image';
1410       return undef;
1411     }
1412     $self->{DEBUG} && print "writing a png file\n";
1413   } elsif ( $input{'type'} eq 'jpeg' ) {
1414     $self->_set_opts(\%input, "jpeg_", $self)
1415       or return undef;
1416     $self->_set_opts(\%input, "exif_", $self)
1417       or return undef;
1418     if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1419       $self->{ERRSTR} = $self->_error_as_msg();
1420       return undef;
1421     }
1422     $self->{DEBUG} && print "writing a jpeg file\n";
1423   } elsif ( $input{'type'} eq 'bmp' ) {
1424     $self->_set_opts(\%input, "bmp_", $self)
1425       or return undef;
1426     if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1427       $self->{ERRSTR}='unable to write bmp image';
1428       return undef;
1429     }
1430     $self->{DEBUG} && print "writing a bmp file\n";
1431   } elsif ( $input{'type'} eq 'tga' ) {
1432     $self->_set_opts(\%input, "tga_", $self)
1433       or return undef;
1434
1435     if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1436       $self->{ERRSTR}=$self->_error_as_msg();
1437       return undef;
1438     }
1439     $self->{DEBUG} && print "writing a tga file\n";
1440   } elsif ( $input{'type'} eq 'gif' ) {
1441     $self->_set_opts(\%input, "gif_", $self)
1442       or return undef;
1443     # compatibility with the old interfaces
1444     if ($input{gifquant} eq 'lm') {
1445       $input{make_colors} = 'addi';
1446       $input{translate} = 'perturb';
1447       $input{perturb} = $input{lmdither};
1448     } elsif ($input{gifquant} eq 'gen') {
1449       # just pass options through
1450     } else {
1451       $input{make_colors} = 'webmap'; # ignored
1452       $input{translate} = 'giflib';
1453     }
1454     if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1455       $self->{ERRSTR} = $self->_error_as_msg;
1456       return;
1457     }
1458   }
1459
1460   if (exists $input{'data'}) {
1461     my $data = io_slurp($IO);
1462     if (!$data) {
1463       $self->{ERRSTR}='Could not slurp from buffer';
1464       return undef;
1465     }
1466     ${$input{data}} = $data;
1467   }
1468   return $self;
1469 }
1470
1471 sub write_multi {
1472   my ($class, $opts, @images) = @_;
1473
1474   if (!$opts->{'type'} && $opts->{'file'}) {
1475     $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1476   }
1477   unless ($opts->{'type'}) {
1478     $class->_set_error('type parameter missing and not possible to guess from extension');
1479     return;
1480   }
1481   # translate to ImgRaw
1482   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1483     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1484     return 0;
1485   }
1486   $class->_set_opts($opts, "i_", @images)
1487     or return;
1488   my @work = map $_->{IMG}, @images;
1489   my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1490     or return undef;
1491   if ($opts->{'type'} eq 'gif') {
1492     $class->_set_opts($opts, "gif_", @images)
1493       or return;
1494     my $gif_delays = $opts->{gif_delays};
1495     local $opts->{gif_delays} = $gif_delays;
1496     if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1497       # assume the caller wants the same delay for each frame
1498       $opts->{gif_delays} = [ ($gif_delays) x @images ];
1499     }
1500     my $res = i_writegif_wiol($IO, $opts, @work);
1501     $res or $class->_set_error($class->_error_as_msg());
1502     return $res;
1503   }
1504   elsif ($opts->{'type'} eq 'tiff') {
1505     $class->_set_opts($opts, "tiff_", @images)
1506       or return;
1507     $class->_set_opts($opts, "exif_", @images)
1508       or return;
1509     my $res;
1510     $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1511     if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1512       $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1513     }
1514     else {
1515       $res = i_writetiff_multi_wiol($IO, @work);
1516     }
1517     $res or $class->_set_error($class->_error_as_msg());
1518     return $res;
1519   }
1520   else {
1521     $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
1522     return 0;
1523   }
1524 }
1525
1526 # read multiple images from a file
1527 sub read_multi {
1528   my ($class, %opts) = @_;
1529
1530   if ($opts{file} && !exists $opts{'type'}) {
1531     # guess the type
1532     my $type = $FORMATGUESS->($opts{file});
1533     $opts{'type'} = $type;
1534   }
1535   unless ($opts{'type'}) {
1536     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1537     return;
1538   }
1539
1540   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1541     or return;
1542   if ($opts{'type'} eq 'gif') {
1543     my @imgs;
1544     @imgs = i_readgif_multi_wiol($IO);
1545     if (@imgs) {
1546       return map {
1547         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1548       } @imgs;
1549     }
1550     else {
1551       $ERRSTR = _error_as_msg();
1552       return;
1553     }
1554   }
1555   elsif ($opts{'type'} eq 'tiff') {
1556     my @imgs = i_readtiff_multi_wiol($IO, -1);
1557     if (@imgs) {
1558       return map {
1559         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1560       } @imgs;
1561     }
1562     else {
1563       $ERRSTR = _error_as_msg();
1564       return;
1565     }
1566   }
1567
1568   $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
1569   return;
1570 }
1571
1572 # Destroy an Imager object
1573
1574 sub DESTROY {
1575   my $self=shift;
1576   #    delete $instances{$self};
1577   if (defined($self->{IMG})) {
1578     # the following is now handled by the XS DESTROY method for
1579     # Imager::ImgRaw object
1580     # Re-enabling this will break virtual images
1581     # tested for in t/t020masked.t
1582     # i_img_destroy($self->{IMG});
1583     undef($self->{IMG});
1584   } else {
1585 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1586   }
1587 }
1588
1589 # Perform an inplace filter of an image
1590 # that is the image will be overwritten with the data
1591
1592 sub filter {
1593   my $self=shift;
1594   my %input=@_;
1595   my %hsh;
1596   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1597
1598   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1599
1600   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1601     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1602   }
1603
1604   if ($filters{$input{'type'}}{names}) {
1605     my $names = $filters{$input{'type'}}{names};
1606     for my $name (keys %$names) {
1607       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1608         $input{$name} = $names->{$name}{$input{$name}};
1609       }
1610     }
1611   }
1612   if (defined($filters{$input{'type'}}{defaults})) {
1613     %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
1614   } else {
1615     %hsh=('image',$self->{IMG},%input);
1616   }
1617
1618   my @cs=@{$filters{$input{'type'}}{callseq}};
1619
1620   for(@cs) {
1621     if (!defined($hsh{$_})) {
1622       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1623     }
1624   }
1625
1626   eval {
1627     local $SIG{__DIE__}; # we don't want this processed by confess, etc
1628     &{$filters{$input{'type'}}{callsub}}(%hsh);
1629   };
1630   if ($@) {
1631     chomp($self->{ERRSTR} = $@);
1632     return;
1633   }
1634
1635   my @b=keys %hsh;
1636
1637   $self->{DEBUG} && print "callseq is: @cs\n";
1638   $self->{DEBUG} && print "matching callseq is: @b\n";
1639
1640   return $self;
1641 }
1642
1643 # Scale an image to requested size and return the scaled version
1644
1645 sub scale {
1646   my $self=shift;
1647   my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
1648   my $img = Imager->new();
1649   my $tmp = Imager->new();
1650
1651   unless (defined wantarray) {
1652     my @caller = caller;
1653     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
1654     return;
1655   }
1656
1657   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1658
1659   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
1660     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
1661     if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1662     if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
1663   } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1664   elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1665
1666   if ($opts{qtype} eq 'normal') {
1667     $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1668     if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1669     $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1670     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1671     return $img;
1672   }
1673   if ($opts{'qtype'} eq 'preview') {
1674     $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
1675     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1676     return $img;
1677   }
1678   $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1679 }
1680
1681 # Scales only along the X axis
1682
1683 sub scaleX {
1684   my $self=shift;
1685   my %opts=(scalefactor=>0.5,@_);
1686
1687   unless (defined wantarray) {
1688     my @caller = caller;
1689     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
1690     return;
1691   }
1692
1693   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1694
1695   my $img = Imager->new();
1696
1697   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1698
1699   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1700   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1701
1702   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1703   return $img;
1704 }
1705
1706 # Scales only along the Y axis
1707
1708 sub scaleY {
1709   my $self=shift;
1710   my %opts=(scalefactor=>0.5,@_);
1711
1712   unless (defined wantarray) {
1713     my @caller = caller;
1714     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
1715     return;
1716   }
1717
1718   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1719
1720   my $img = Imager->new();
1721
1722   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1723
1724   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1725   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1726
1727   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1728   return $img;
1729 }
1730
1731
1732 # Transform returns a spatial transformation of the input image
1733 # this moves pixels to a new location in the returned image.
1734 # NOTE - should make a utility function to check transforms for
1735 # stack overruns
1736
1737 sub transform {
1738   my $self=shift;
1739   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1740   my %opts=@_;
1741   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1742
1743 #  print Dumper(\%opts);
1744 #  xopcopdes
1745
1746   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1747     if (!$I2P) {
1748       eval ("use Affix::Infix2Postfix;");
1749       print $@;
1750       if ( $@ ) {
1751         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
1752         return undef;
1753       }
1754       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1755                                              {op=>'-',trans=>'Sub'},
1756                                              {op=>'*',trans=>'Mult'},
1757                                              {op=>'/',trans=>'Div'},
1758                                              {op=>'-','type'=>'unary',trans=>'u-'},
1759                                              {op=>'**'},
1760                                              {op=>'func','type'=>'unary'}],
1761                                      'grouping'=>[qw( \( \) )],
1762                                      'func'=>[qw( sin cos )],
1763                                      'vars'=>[qw( x y )]
1764                                     );
1765     }
1766
1767     @xt=$I2P->translate($opts{'xexpr'});
1768     @yt=$I2P->translate($opts{'yexpr'});
1769
1770     $numre=$I2P->{'numre'};
1771     @pt=(0,0);
1772
1773     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1774     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1775     @{$opts{'parm'}}=@pt;
1776   }
1777
1778 #  print Dumper(\%opts);
1779
1780   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1781     $self->{ERRSTR}='transform: no xopcodes given.';
1782     return undef;
1783   }
1784
1785   @op=@{$opts{'xopcodes'}};
1786   for $iop (@op) {
1787     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1788       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1789       return undef;
1790     }
1791     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1792   }
1793
1794
1795 # yopcopdes
1796
1797   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1798     $self->{ERRSTR}='transform: no yopcodes given.';
1799     return undef;
1800   }
1801
1802   @op=@{$opts{'yopcodes'}};
1803   for $iop (@op) {
1804     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1805       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1806       return undef;
1807     }
1808     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1809   }
1810
1811 #parameters
1812
1813   if ( !exists $opts{'parm'}) {
1814     $self->{ERRSTR}='transform: no parameter arg given.';
1815     return undef;
1816   }
1817
1818 #  print Dumper(\@ropx);
1819 #  print Dumper(\@ropy);
1820 #  print Dumper(\@ropy);
1821
1822   my $img = Imager->new();
1823   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1824   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1825   return $img;
1826 }
1827
1828
1829 sub transform2 {
1830   my ($opts, @imgs) = @_;
1831
1832   require "Imager/Expr.pm";
1833
1834   $opts->{variables} = [ qw(x y) ];
1835   my ($width, $height) = @{$opts}{qw(width height)};
1836   if (@imgs) {
1837     $width ||= $imgs[0]->getwidth();
1838     $height ||= $imgs[0]->getheight();
1839     my $img_num = 1;
1840     for my $img (@imgs) {
1841       $opts->{constants}{"w$img_num"} = $img->getwidth();
1842       $opts->{constants}{"h$img_num"} = $img->getheight();
1843       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1844       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1845       ++$img_num;
1846     }
1847   }
1848   if ($width) {
1849     $opts->{constants}{w} = $width;
1850     $opts->{constants}{cx} = $width/2;
1851   }
1852   else {
1853     $Imager::ERRSTR = "No width supplied";
1854     return;
1855   }
1856   if ($height) {
1857     $opts->{constants}{h} = $height;
1858     $opts->{constants}{cy} = $height/2;
1859   }
1860   else {
1861     $Imager::ERRSTR = "No height supplied";
1862     return;
1863   }
1864   my $code = Imager::Expr->new($opts);
1865   if (!$code) {
1866     $Imager::ERRSTR = Imager::Expr::error();
1867     return;
1868   }
1869   my $channels = $opts->{channels} || 3;
1870   unless ($channels >= 1 && $channels <= 4) {
1871     return Imager->_set_error("channels must be an integer between 1 and 4");
1872   }
1873
1874   my $img = Imager->new();
1875   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
1876                              $channels, $code->code(),
1877                              $code->nregs(), $code->cregs(),
1878                              [ map { $_->{IMG} } @imgs ]);
1879   if (!defined $img->{IMG}) {
1880     $Imager::ERRSTR = Imager->_error_as_msg();
1881     return;
1882   }
1883
1884   return $img;
1885 }
1886
1887 sub rubthrough {
1888   my $self=shift;
1889   my %opts=(tx => 0,ty => 0, @_);
1890
1891   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1892   unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1893
1894   %opts = (src_minx => 0,
1895            src_miny => 0,
1896            src_maxx => $opts{src}->getwidth(),
1897            src_maxy => $opts{src}->getheight(),
1898            %opts);
1899
1900   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx}, $opts{ty},
1901           $opts{src_minx}, $opts{src_miny}, $opts{src_maxx}, $opts{src_maxy})) {
1902     $self->{ERRSTR} = $self->_error_as_msg();
1903     return undef;
1904   }
1905   return $self;
1906 }
1907
1908
1909 sub flip {
1910   my $self  = shift;
1911   my %opts  = @_;
1912   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
1913   my $dir;
1914   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1915   $dir = $xlate{$opts{'dir'}};
1916   return $self if i_flipxy($self->{IMG}, $dir);
1917   return ();
1918 }
1919
1920 sub rotate {
1921   my $self = shift;
1922   my %opts = @_;
1923
1924   unless (defined wantarray) {
1925     my @caller = caller;
1926     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
1927     return;
1928   }
1929
1930   if (defined $opts{right}) {
1931     my $degrees = $opts{right};
1932     if ($degrees < 0) {
1933       $degrees += 360 * int(((-$degrees)+360)/360);
1934     }
1935     $degrees = $degrees % 360;
1936     if ($degrees == 0) {
1937       return $self->copy();
1938     }
1939     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1940       my $result = Imager->new();
1941       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1942         return $result;
1943       }
1944       else {
1945         $self->{ERRSTR} = $self->_error_as_msg();
1946         return undef;
1947       }
1948     }
1949     else {
1950       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1951       return undef;
1952     }
1953   }
1954   elsif (defined $opts{radians} || defined $opts{degrees}) {
1955     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1956
1957     my $result = Imager->new;
1958     if ($opts{back}) {
1959       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $opts{back});
1960     }
1961     else {
1962       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
1963     }
1964     if ($result->{IMG}) {
1965       return $result;
1966     }
1967     else {
1968       $self->{ERRSTR} = $self->_error_as_msg();
1969       return undef;
1970     }
1971   }
1972   else {
1973     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
1974     return undef;
1975   }
1976 }
1977
1978 sub matrix_transform {
1979   my $self = shift;
1980   my %opts = @_;
1981
1982   unless (defined wantarray) {
1983     my @caller = caller;
1984     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
1985     return;
1986   }
1987
1988   if ($opts{matrix}) {
1989     my $xsize = $opts{xsize} || $self->getwidth;
1990     my $ysize = $opts{ysize} || $self->getheight;
1991
1992     my $result = Imager->new;
1993     if ($opts{back}) {
1994       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1995                                           $opts{matrix}, $opts{back})
1996         or return undef;
1997     }
1998     else {
1999       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2000                                           $opts{matrix})
2001         or return undef;
2002     }
2003
2004     return $result;
2005   }
2006   else {
2007     $self->{ERRSTR} = "matrix parameter required";
2008     return undef;
2009   }
2010 }
2011
2012 # blame Leolo :)
2013 *yatf = \&matrix_transform;
2014
2015 # These two are supported for legacy code only
2016
2017 sub i_color_new {
2018   return Imager::Color->new(@_);
2019 }
2020
2021 sub i_color_set {
2022   return Imager::Color::set(@_);
2023 }
2024
2025 # Draws a box between the specified corner points.
2026 sub box {
2027   my $self=shift;
2028   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2029   my $dflcl=i_color_new(255,255,255,255);
2030   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2031
2032   if (exists $opts{'box'}) {
2033     $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
2034     $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
2035     $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
2036     $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
2037   }
2038
2039   if ($opts{filled}) {
2040     my $color = _color($opts{'color'});
2041     unless ($color) {
2042       $self->{ERRSTR} = $Imager::ERRSTR;
2043       return;
2044     }
2045     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2046                  $opts{ymax}, $color);
2047   }
2048   elsif ($opts{fill}) {
2049     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2050       # assume it's a hash ref
2051       require 'Imager/Fill.pm';
2052       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2053         $self->{ERRSTR} = $Imager::ERRSTR;
2054         return undef;
2055       }
2056     }
2057     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2058                 $opts{ymax},$opts{fill}{fill});
2059   }
2060   else {
2061     my $color = _color($opts{'color'});
2062     unless ($color) {
2063       $self->{ERRSTR} = $Imager::ERRSTR;
2064       return;
2065     }
2066     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2067           $color);
2068   }
2069   return $self;
2070 }
2071
2072 # Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
2073
2074 sub arc {
2075   my $self=shift;
2076   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2077   my $dflcl=i_color_new(255,255,255,255);
2078   my %opts=(color=>$dflcl,
2079             'r'=>min($self->getwidth(),$self->getheight())/3,
2080             'x'=>$self->getwidth()/2,
2081             'y'=>$self->getheight()/2,
2082             'd1'=>0, 'd2'=>361, @_);
2083   if ($opts{fill}) {
2084     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2085       # assume it's a hash ref
2086       require 'Imager/Fill.pm';
2087       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2088         $self->{ERRSTR} = $Imager::ERRSTR;
2089         return;
2090       }
2091     }
2092     i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2093                 $opts{'d2'}, $opts{fill}{fill});
2094   }
2095   else {
2096     my $color = _color($opts{'color'});
2097     unless ($color) {
2098       $self->{ERRSTR} = $Imager::ERRSTR;
2099       return;
2100     }
2101     if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2102       i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2103                   $color);
2104     }
2105     else {
2106       if ($opts{'d1'} <= $opts{'d2'}) {
2107         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2108               $opts{'d1'}, $opts{'d2'}, $color);
2109       }
2110       else {
2111         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2112               $opts{'d1'}, 361,         $color);
2113         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2114               0,           $opts{'d2'}, $color);
2115       }
2116     }
2117   }
2118
2119   return $self;
2120 }
2121
2122 # Draws a line from one point to the other
2123 # the endpoint is set if the endp parameter is set which it is by default.
2124 # to turn of the endpoint being set use endp=>0 when calling line.
2125
2126 sub line {
2127   my $self=shift;
2128   my $dflcl=i_color_new(0,0,0,0);
2129   my %opts=(color=>$dflcl,
2130             endp => 1,
2131             @_);
2132   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2133
2134   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2135   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2136
2137   my $color = _color($opts{'color'});
2138   unless ($color) {
2139     $self->{ERRSTR} = $Imager::ERRSTR;
2140     return;
2141   }
2142
2143   $opts{antialias} = $opts{aa} if defined $opts{aa};
2144   if ($opts{antialias}) {
2145     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2146               $color, $opts{endp});
2147   } else {
2148     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2149            $color, $opts{endp});
2150   }
2151   return $self;
2152 }
2153
2154 # Draws a line between an ordered set of points - It more or less just transforms this
2155 # into a list of lines.
2156
2157 sub polyline {
2158   my $self=shift;
2159   my ($pt,$ls,@points);
2160   my $dflcl=i_color_new(0,0,0,0);
2161   my %opts=(color=>$dflcl,@_);
2162
2163   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2164
2165   if (exists($opts{points})) { @points=@{$opts{points}}; }
2166   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2167     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2168     }
2169
2170 #  print Dumper(\@points);
2171
2172   my $color = _color($opts{'color'});
2173   unless ($color) {
2174     $self->{ERRSTR} = $Imager::ERRSTR;
2175     return;
2176   }
2177   $opts{antialias} = $opts{aa} if defined $opts{aa};
2178   if ($opts{antialias}) {
2179     for $pt(@points) {
2180       if (defined($ls)) {
2181         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2182       }
2183       $ls=$pt;
2184     }
2185   } else {
2186     for $pt(@points) {
2187       if (defined($ls)) {
2188         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2189       }
2190       $ls=$pt;
2191     }
2192   }
2193   return $self;
2194 }
2195
2196 sub polygon {
2197   my $self = shift;
2198   my ($pt,$ls,@points);
2199   my $dflcl = i_color_new(0,0,0,0);
2200   my %opts = (color=>$dflcl, @_);
2201
2202   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2203
2204   if (exists($opts{points})) {
2205     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2206     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2207   }
2208
2209   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2210     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2211   }
2212
2213   if ($opts{'fill'}) {
2214     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2215       # assume it's a hash ref
2216       require 'Imager/Fill.pm';
2217       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2218         $self->{ERRSTR} = $Imager::ERRSTR;
2219         return undef;
2220       }
2221     }
2222     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2223                     $opts{'fill'}{'fill'});
2224   }
2225   else {
2226     my $color = _color($opts{'color'});
2227     unless ($color) {
2228       $self->{ERRSTR} = $Imager::ERRSTR;
2229       return;
2230     }
2231     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2232   }
2233
2234   return $self;
2235 }
2236
2237
2238 # this the multipoint bezier curve
2239 # this is here more for testing that actual usage since
2240 # this is not a good algorithm.  Usually the curve would be
2241 # broken into smaller segments and each done individually.
2242
2243 sub polybezier {
2244   my $self=shift;
2245   my ($pt,$ls,@points);
2246   my $dflcl=i_color_new(0,0,0,0);
2247   my %opts=(color=>$dflcl,@_);
2248
2249   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2250
2251   if (exists $opts{points}) {
2252     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2253     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2254   }
2255
2256   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2257     $self->{ERRSTR}='Missing or invalid points.';
2258     return;
2259   }
2260
2261   my $color = _color($opts{'color'});
2262   unless ($color) {
2263     $self->{ERRSTR} = $Imager::ERRSTR;
2264     return;
2265   }
2266   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2267   return $self;
2268 }
2269
2270 sub flood_fill {
2271   my $self = shift;
2272   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2273   my $rc;
2274
2275   unless (exists $opts{'x'} && exists $opts{'y'}) {
2276     $self->{ERRSTR} = "missing seed x and y parameters";
2277     return undef;
2278   }
2279
2280   if ($opts{fill}) {
2281     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2282       # assume it's a hash ref
2283       require 'Imager/Fill.pm';
2284       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2285         $self->{ERRSTR} = $Imager::ERRSTR;
2286         return;
2287       }
2288     }
2289     $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2290   }
2291   else {
2292     my $color = _color($opts{'color'});
2293     unless ($color) {
2294       $self->{ERRSTR} = $Imager::ERRSTR;
2295       return;
2296     }
2297     $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2298   }
2299   if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
2300 }
2301
2302 sub setpixel {
2303   my $self = shift;
2304
2305   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2306
2307   unless (exists $opts{'x'} && exists $opts{'y'}) {
2308     $self->{ERRSTR} = 'missing x and y parameters';
2309     return undef;
2310   }
2311
2312   my $x = $opts{'x'};
2313   my $y = $opts{'y'};
2314   my $color = _color($opts{color})
2315     or return undef;
2316   if (ref $x && ref $y) {
2317     unless (@$x == @$y) {
2318       $self->{ERRSTR} = 'length of x and y mismatch';
2319       return undef;
2320     }
2321     if ($color->isa('Imager::Color')) {
2322       for my $i (0..$#{$opts{'x'}}) {
2323         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2324       }
2325     }
2326     else {
2327       for my $i (0..$#{$opts{'x'}}) {
2328         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2329       }
2330     }
2331   }
2332   else {
2333     if ($color->isa('Imager::Color')) {
2334       i_ppix($self->{IMG}, $x, $y, $color);
2335     }
2336     else {
2337       i_ppixf($self->{IMG}, $x, $y, $color);
2338     }
2339   }
2340
2341   $self;
2342 }
2343
2344 sub getpixel {
2345   my $self = shift;
2346
2347   my %opts = ( "type"=>'8bit', @_);
2348
2349   unless (exists $opts{'x'} && exists $opts{'y'}) {
2350     $self->{ERRSTR} = 'missing x and y parameters';
2351     return undef;
2352   }
2353
2354   my $x = $opts{'x'};
2355   my $y = $opts{'y'};
2356   if (ref $x && ref $y) {
2357     unless (@$x == @$y) {
2358       $self->{ERRSTR} = 'length of x and y mismatch';
2359       return undef;
2360     }
2361     my @result;
2362     if ($opts{"type"} eq '8bit') {
2363       for my $i (0..$#{$opts{'x'}}) {
2364         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2365       }
2366     }
2367     else {
2368       for my $i (0..$#{$opts{'x'}}) {
2369         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2370       }
2371     }
2372     return wantarray ? @result : \@result;
2373   }
2374   else {
2375     if ($opts{"type"} eq '8bit') {
2376       return i_get_pixel($self->{IMG}, $x, $y);
2377     }
2378     else {
2379       return i_gpixf($self->{IMG}, $x, $y);
2380     }
2381   }
2382
2383   $self;
2384 }
2385
2386 sub getscanline {
2387   my $self = shift;
2388   my %opts = ( type => '8bit', x=>0, @_);
2389
2390   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2391
2392   unless (defined $opts{'y'}) {
2393     $self->_set_error("missing y parameter");
2394     return;
2395   }
2396
2397   if ($opts{type} eq '8bit') {
2398     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2399                   $opts{y});
2400   }
2401   elsif ($opts{type} eq 'float') {
2402     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2403                   $opts{y});
2404   }
2405   else {
2406     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2407     return;
2408   }
2409 }
2410
2411 sub setscanline {
2412   my $self = shift;
2413   my %opts = ( x=>0, @_);
2414
2415   unless (defined $opts{'y'}) {
2416     $self->_set_error("missing y parameter");
2417     return;
2418   }
2419
2420   if (!$opts{type}) {
2421     if (ref $opts{pixels} && @{$opts{pixels}}) {
2422       # try to guess the type
2423       if ($opts{pixels}[0]->isa('Imager::Color')) {
2424         $opts{type} = '8bit';
2425       }
2426       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
2427         $opts{type} = 'float';
2428       }
2429       else {
2430         $self->_set_error("missing type parameter and could not guess from pixels");
2431         return;
2432       }
2433     }
2434     else {
2435       # default
2436       $opts{type} = '8bit';
2437     }
2438   }
2439
2440   if ($opts{type} eq '8bit') {
2441     if (ref $opts{pixels}) {
2442       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2443     }
2444     else {
2445       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2446     }
2447   }
2448   elsif ($opts{type} eq 'float') {
2449     if (ref $opts{pixels}) {
2450       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
2451     }
2452     else {
2453       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
2454     }
2455   }
2456   else {
2457     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2458     return;
2459   }
2460 }
2461
2462 sub getsamples {
2463   my $self = shift;
2464   my %opts = ( type => '8bit', x=>0, @_);
2465
2466   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
2467
2468   unless (defined $opts{'y'}) {
2469     $self->_set_error("missing y parameter");
2470     return;
2471   }
2472
2473   unless ($opts{channels}) {
2474     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
2475   }
2476
2477   if ($opts{type} eq '8bit') {
2478     return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2479                    $opts{y}, @{$opts{channels}});
2480   }
2481   elsif ($opts{type} eq 'float') {
2482     return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
2483                     $opts{y}, @{$opts{channels}});
2484   }
2485   else {
2486     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
2487     return;
2488   }
2489 }
2490
2491 # make an identity matrix of the given size
2492 sub _identity {
2493   my ($size) = @_;
2494
2495   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2496   for my $c (0 .. ($size-1)) {
2497     $matrix->[$c][$c] = 1;
2498   }
2499   return $matrix;
2500 }
2501
2502 # general function to convert an image
2503 sub convert {
2504   my ($self, %opts) = @_;
2505   my $matrix;
2506
2507   unless (defined wantarray) {
2508     my @caller = caller;
2509     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
2510     return;
2511   }
2512
2513   # the user can either specify a matrix or preset
2514   # the matrix overrides the preset
2515   if (!exists($opts{matrix})) {
2516     unless (exists($opts{preset})) {
2517       $self->{ERRSTR} = "convert() needs a matrix or preset";
2518       return;
2519     }
2520     else {
2521       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2522         # convert to greyscale, keeping the alpha channel if any
2523         if ($self->getchannels == 3) {
2524           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2525         }
2526         elsif ($self->getchannels == 4) {
2527           # preserve the alpha channel
2528           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2529                       [ 0,     0,     0,     1 ] ];
2530         }
2531         else {
2532           # an identity
2533           $matrix = _identity($self->getchannels);
2534         }
2535       }
2536       elsif ($opts{preset} eq 'noalpha') {
2537         # strip the alpha channel
2538         if ($self->getchannels == 2 or $self->getchannels == 4) {
2539           $matrix = _identity($self->getchannels);
2540           pop(@$matrix); # lose the alpha entry
2541         }
2542         else {
2543           $matrix = _identity($self->getchannels);
2544         }
2545       }
2546       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2547         # extract channel 0
2548         $matrix = [ [ 1 ] ];
2549       }
2550       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2551         $matrix = [ [ 0, 1 ] ];
2552       }
2553       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2554         $matrix = [ [ 0, 0, 1 ] ];
2555       }
2556       elsif ($opts{preset} eq 'alpha') {
2557         if ($self->getchannels == 2 or $self->getchannels == 4) {
2558           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2559         }
2560         else {
2561           # the alpha is just 1 <shrug>
2562           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2563         }
2564       }
2565       elsif ($opts{preset} eq 'rgb') {
2566         if ($self->getchannels == 1) {
2567           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2568         }
2569         elsif ($self->getchannels == 2) {
2570           # preserve the alpha channel
2571           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2572         }
2573         else {
2574           $matrix = _identity($self->getchannels);
2575         }
2576       }
2577       elsif ($opts{preset} eq 'addalpha') {
2578         if ($self->getchannels == 1) {
2579           $matrix = _identity(2);
2580         }
2581         elsif ($self->getchannels == 3) {
2582           $matrix = _identity(4);
2583         }
2584         else {
2585           $matrix = _identity($self->getchannels);
2586         }
2587       }
2588       else {
2589         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2590         return undef;
2591       }
2592     }
2593   }
2594   else {
2595     $matrix = $opts{matrix};
2596   }
2597
2598   my $new = Imager->new();
2599   $new->{IMG} = i_img_new();
2600   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2601     # most likely a bad matrix
2602     $self->{ERRSTR} = _error_as_msg();
2603     return undef;
2604   }
2605   return $new;
2606 }
2607
2608
2609 # general function to map an image through lookup tables
2610
2611 sub map {
2612   my ($self, %opts) = @_;
2613   my @chlist = qw( red green blue alpha );
2614
2615   if (!exists($opts{'maps'})) {
2616     # make maps from channel maps
2617     my $chnum;
2618     for $chnum (0..$#chlist) {
2619       if (exists $opts{$chlist[$chnum]}) {
2620         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2621       } elsif (exists $opts{'all'}) {
2622         $opts{'maps'}[$chnum] = $opts{'all'};
2623       }
2624     }
2625   }
2626   if ($opts{'maps'} and $self->{IMG}) {
2627     i_map($self->{IMG}, $opts{'maps'} );
2628   }
2629   return $self;
2630 }
2631
2632 sub difference {
2633   my ($self, %opts) = @_;
2634
2635   defined $opts{mindist} or $opts{mindist} = 0;
2636
2637   defined $opts{other}
2638     or return $self->_set_error("No 'other' parameter supplied");
2639   defined $opts{other}{IMG}
2640     or return $self->_set_error("No image data in 'other' image");
2641
2642   $self->{IMG}
2643     or return $self->_set_error("No image data");
2644
2645   my $result = Imager->new;
2646   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
2647                                 $opts{mindist})
2648     or return $self->_set_error($self->_error_as_msg());
2649
2650   return $result;
2651 }
2652
2653 # destructive border - image is shrunk by one pixel all around
2654
2655 sub border {
2656   my ($self,%opts)=@_;
2657   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2658   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2659 }
2660
2661
2662 # Get the width of an image
2663
2664 sub getwidth {
2665   my $self = shift;
2666   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2667   return (i_img_info($self->{IMG}))[0];
2668 }
2669
2670 # Get the height of an image
2671
2672 sub getheight {
2673   my $self = shift;
2674   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2675   return (i_img_info($self->{IMG}))[1];
2676 }
2677
2678 # Get number of channels in an image
2679
2680 sub getchannels {
2681   my $self = shift;
2682   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2683   return i_img_getchannels($self->{IMG});
2684 }
2685
2686 # Get channel mask
2687
2688 sub getmask {
2689   my $self = shift;
2690   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2691   return i_img_getmask($self->{IMG});
2692 }
2693
2694 # Set channel mask
2695
2696 sub setmask {
2697   my $self = shift;
2698   my %opts = @_;
2699   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2700   i_img_setmask( $self->{IMG} , $opts{mask} );
2701 }
2702
2703 # Get number of colors in an image
2704
2705 sub getcolorcount {
2706   my $self=shift;
2707   my %opts=('maxcolors'=>2**30,@_);
2708   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2709   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2710   return ($rc==-1? undef : $rc);
2711 }
2712
2713 # draw string to an image
2714
2715 sub string {
2716   my $self = shift;
2717   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2718
2719   my %input=('x'=>0, 'y'=>0, @_);
2720   $input{string}||=$input{text};
2721
2722   unless(exists $input{string}) {
2723     $self->{ERRSTR}="missing required parameter 'string'";
2724     return;
2725   }
2726
2727   unless($input{font}) {
2728     $self->{ERRSTR}="missing required parameter 'font'";
2729     return;
2730   }
2731
2732   unless ($input{font}->draw(image=>$self, %input)) {
2733     $self->{ERRSTR} = $self->_error_as_msg();
2734     return;
2735   }
2736
2737   return $self;
2738 }
2739
2740 my @file_limit_names = qw/width height bytes/;
2741
2742 sub set_file_limits {
2743   shift;
2744
2745   my %opts = @_;
2746   my %values;
2747
2748   if ($opts{reset}) {
2749     @values{@file_limit_names} = (0) x @file_limit_names;
2750   }
2751   else {
2752     @values{@file_limit_names} = i_get_image_file_limits();
2753   }
2754
2755   for my $key (keys %values) {
2756     defined $opts{$key} and $values{$key} = $opts{$key};
2757   }
2758
2759   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
2760 }
2761
2762 sub get_file_limits {
2763   i_get_image_file_limits();
2764 }
2765
2766 # Shortcuts that can be exported
2767
2768 sub newcolor { Imager::Color->new(@_); }
2769 sub newfont  { Imager::Font->new(@_); }
2770
2771 *NC=*newcolour=*newcolor;
2772 *NF=*newfont;
2773
2774 *open=\&read;
2775 *circle=\&arc;
2776
2777
2778 #### Utility routines
2779
2780 sub errstr {
2781   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2782 }
2783
2784 sub _set_error {
2785   my ($self, $msg) = @_;
2786
2787   if (ref $self) {
2788     $self->{ERRSTR} = $msg;
2789   }
2790   else {
2791     $ERRSTR = $msg;
2792   }
2793   return;
2794 }
2795
2796 # Default guess for the type of an image from extension
2797
2798 sub def_guess_type {
2799   my $name=lc(shift);
2800   my $ext;
2801   $ext=($name =~ m/\.([^\.]+)$/)[0];
2802   return 'tiff' if ($ext =~ m/^tiff?$/);
2803   return 'jpeg' if ($ext =~ m/^jpe?g$/);
2804   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
2805   return 'png'  if ($ext eq "png");
2806   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
2807   return 'tga'  if ($ext eq "tga");
2808   return 'rgb'  if ($ext eq "rgb");
2809   return 'gif'  if ($ext eq "gif");
2810   return 'raw'  if ($ext eq "raw");
2811   return ();
2812 }
2813
2814 # get the minimum of a list
2815
2816 sub min {
2817   my $mx=shift;
2818   for(@_) { if ($_<$mx) { $mx=$_; }}
2819   return $mx;
2820 }
2821
2822 # get the maximum of a list
2823
2824 sub max {
2825   my $mx=shift;
2826   for(@_) { if ($_>$mx) { $mx=$_; }}
2827   return $mx;
2828 }
2829
2830 # string stuff for iptc headers
2831
2832 sub clean {
2833   my($str)=$_[0];
2834   $str = substr($str,3);
2835   $str =~ s/[\n\r]//g;
2836   $str =~ s/\s+/ /g;
2837   $str =~ s/^\s//;
2838   $str =~ s/\s$//;
2839   return $str;
2840 }
2841
2842 # A little hack to parse iptc headers.
2843
2844 sub parseiptc {
2845   my $self=shift;
2846   my(@sar,$item,@ar);
2847   my($caption,$photogr,$headln,$credit);
2848
2849   my $str=$self->{IPTCRAW};
2850
2851   #print $str;
2852
2853   @ar=split(/8BIM/,$str);
2854
2855   my $i=0;
2856   foreach (@ar) {
2857     if (/^\004\004/) {
2858       @sar=split(/\034\002/);
2859       foreach $item (@sar) {
2860         if ($item =~ m/^x/) {
2861           $caption=&clean($item);
2862           $i++;
2863         }
2864         if ($item =~ m/^P/) {
2865           $photogr=&clean($item);
2866           $i++;
2867         }
2868         if ($item =~ m/^i/) {
2869           $headln=&clean($item);
2870           $i++;
2871         }
2872         if ($item =~ m/^n/) {
2873           $credit=&clean($item);
2874           $i++;
2875         }
2876       }
2877     }
2878   }
2879   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2880 }
2881
2882 # Autoload methods go after =cut, and are processed by the autosplit program.
2883
2884 1;
2885 __END__
2886 # Below is the stub of documentation for your module. You better edit it!
2887
2888 =head1 NAME
2889
2890 Imager - Perl extension for Generating 24 bit Images
2891
2892 =head1 SYNOPSIS
2893
2894   # Thumbnail example
2895
2896   #!/usr/bin/perl -w
2897   use strict;
2898   use Imager;
2899
2900   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2901   my $file = shift;
2902
2903   my $format;
2904
2905   my $img = Imager->new();
2906   # see Imager::Files for information on the read() method
2907   $img->read(file=>$file) or die $img->errstr();
2908
2909   $file =~ s/\.[^.]*$//;
2910
2911   # Create smaller version
2912   # documented in Imager::Transformations
2913   my $thumb = $img->scale(scalefactor=>.3);
2914
2915   # Autostretch individual channels
2916   $thumb->filter(type=>'autolevels');
2917
2918   # try to save in one of these formats
2919   SAVE:
2920
2921   for $format ( qw( png gif jpg tiff ppm ) ) {
2922     # Check if given format is supported
2923     if ($Imager::formats{$format}) {
2924       $file.="_low.$format";
2925       print "Storing image as: $file\n";
2926       # documented in Imager::Files
2927       $thumb->write(file=>$file) or
2928         die $thumb->errstr;
2929       last SAVE;
2930     }
2931   }
2932
2933 =head1 DESCRIPTION
2934
2935 Imager is a module for creating and altering images.  It can read and
2936 write various image formats, draw primitive shapes like lines,and
2937 polygons, blend multiple images together in various ways, scale, crop,
2938 render text and more.
2939
2940 =head2 Overview of documentation
2941
2942 =over
2943
2944 =item *
2945
2946 Imager - This document - Synopsis Example, Table of Contents and
2947 Overview.
2948
2949 =item *
2950
2951 L<Imager::Cookbook> - how to do various things with Imager.
2952
2953 =item *
2954
2955 L<Imager::ImageTypes> - Basics of constructing image objects with
2956 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
2957 8/16/double bits/channel, color maps, channel masks, image tags, color
2958 quantization.  Also discusses basic image information methods.
2959
2960 =item *
2961
2962 L<Imager::Files> - IO interaction, reading/writing images, format
2963 specific tags.
2964
2965 =item *
2966
2967 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
2968 flood fill.
2969
2970 =item *
2971
2972 L<Imager::Color> - Color specification.
2973
2974 =item *
2975
2976 L<Imager::Fill> - Fill pattern specification.
2977
2978 =item *
2979
2980 L<Imager::Font> - General font rendering, bounding boxes and font
2981 metrics.
2982
2983 =item *
2984
2985 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
2986 blending, pasting, convert and map.
2987
2988 =item *
2989
2990 L<Imager::Engines> - Programmable transformations through
2991 C<transform()>, C<transform2()> and C<matrix_transform()>.
2992
2993 =item *
2994
2995 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
2996 filter plugins.
2997
2998 =item *
2999
3000 L<Imager::Expr> - Expressions for evaluation engine used by
3001 transform2().
3002
3003 =item *
3004
3005 L<Imager::Matrix2d> - Helper class for affine transformations.
3006
3007 =item *
3008
3009 L<Imager::Fountain> - Helper for making gradient profiles.
3010
3011 =back
3012
3013 =head2 Basic Overview
3014
3015 An Image object is created with C<$img = Imager-E<gt>new()>.
3016 Examples:
3017
3018   $img=Imager->new();                         # create empty image
3019   $img->read(file=>'lena.png',type=>'png') or # read image from file
3020      die $img->errstr();                      # give an explanation
3021                                               # if something failed
3022
3023 or if you want to create an empty image:
3024
3025   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
3026
3027 This example creates a completely black image of width 400 and height
3028 300 and 4 channels.
3029
3030 When an operation fails which can be directly associated with an image
3031 the error message is stored can be retrieved with
3032 C<$img-E<gt>errstr()>.
3033
3034 In cases where no image object is associated with an operation
3035 C<$Imager::ERRSTR> is used to report errors not directly associated
3036 with an image object.  You can also call C<Imager->errstr> to get this
3037 value.
3038
3039 The C<Imager-E<gt>new> method is described in detail in
3040 L<Imager::ImageTypes>.
3041
3042 =head1 METHOD INDEX
3043
3044 Where to find information on methods for Imager class objects.
3045
3046 addcolors() -  L<Imager::ImageTypes>
3047
3048 addtag() -  L<Imager::ImageTypes> - add image tags
3049
3050 arc() - L<Imager::Draw/arc>
3051
3052 bits() - L<Imager::ImageTypes> - number of bits per sample for the
3053 image
3054
3055 box() - L<Imager::Draw/box>
3056
3057 circle() - L<Imager::Draw/circle>
3058
3059 colorcount() - L<Imager::Draw/colorcount>
3060
3061 convert() - L<Imager::Transformations/"Color transformations"> -
3062 transform the color space
3063
3064 copy() - L<Imager::Transformations/copy>
3065
3066 crop() - L<Imager::Transformations/crop> - extract part of an image
3067
3068 deltag() -  L<Imager::ImageTypes> - delete image tags
3069
3070 difference() - L<Imager::Filters/"Image Difference">
3071
3072 errstr() - L<Imager/"Basic Overview">
3073
3074 filter() - L<Imager::Filters>
3075
3076 findcolor() - L<Imager::ImageTypes> - search the image palette, if it
3077 has one
3078
3079 flip() - L<Imager::Transformations/flip>
3080
3081 flood_fill() - L<Imager::Draw/flood_fill>
3082
3083 getchannels() -  L<Imager::ImageTypes>
3084
3085 getcolorcount() -  L<Imager::ImageTypes>
3086
3087 getcolors() - L<Imager::ImageTypes> - get colors from the image
3088 palette, if it has one
3089
3090 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3091
3092 getheight() - L<Imager::ImageTypes>
3093
3094 getpixel() - L<Imager::Draw/setpixel and getpixel>
3095
3096 getsamples() - L<Imager::Draw/getsamples>
3097
3098 getscanline() - L<Imager::Draw/getscanline>
3099
3100 getwidth() - L<Imager::ImageTypes>
3101
3102 img_set() - L<Imager::ImageTypes>
3103
3104 line() - L<Imager::Draw/line>
3105
3106 map() - L<Imager::Transformations/"Color Mappings"> - remap color
3107 channel values
3108
3109 masked() -  L<Imager::ImageTypes> - make a masked image
3110
3111 matrix_transform() - L<Imager::Engines/"Matrix Transformations">
3112
3113 maxcolors() - L<Imager::ImageTypes/maxcolor>
3114
3115 new() - L<Imager::ImageTypes>
3116
3117 open() - L<Imager::Files> - an alias for read()
3118
3119 paste() - L<Imager::Transformations/paste> - draw an image onto an image
3120
3121 polygon() - L<Imager::Draw/polygon>
3122
3123 polyline() - L<Imager::Draw/polyline>
3124
3125 read() - L<Imager::Files> - read a single image from an image file
3126
3127 read_multi() - L<Imager::Files> - read multiple images from an image
3128 file
3129
3130 rotate() - L<Imager::Transformations/rotate>
3131
3132 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
3133 image and use the alpha channel
3134
3135 scale() - L<Imager::Transformations/scale>
3136
3137 setscanline() - L<Imager::Draw/setscanline>
3138
3139 scaleX() - L<Imager::Transformations/scaleX>
3140
3141 scaleY() - L<Imager::Transformations/scaleY>
3142
3143 setcolors() - L<Imager::ImageTypes> - set palette colors in a paletted image
3144
3145 setpixel() - L<Imager::Draw/setpixel and getpixel>
3146
3147 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
3148
3149 string() - L<Imager::Font/string> - draw text on an image
3150
3151 tags() -  L<Imager::ImageTypes> - fetch image tags
3152
3153 to_paletted() -  L<Imager::ImageTypes>
3154
3155 to_rgb8() - L<Imager::ImageTypes>
3156
3157 transform() - L<Imager::Engines/"transform">
3158
3159 transform2() - L<Imager::Engines/"transform2">
3160
3161 type() -  L<Imager::ImageTypes> - type of image (direct vs paletted)
3162
3163 virtual() - L<Imager::ImageTypes> - whether the image has it's own
3164 data
3165
3166 write() - L<Imager::Files> - write an image to a file
3167
3168 write_multi() - L<Imager::Files> - write multiple image to an image
3169 file.
3170
3171 =head1 CONCEPT INDEX
3172
3173 animated GIF - L<Imager::File/"Writing an animated GIF">
3174
3175 aspect ratio - L<Imager::ImageTypes/i_xres>,
3176 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
3177
3178 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
3179
3180 boxes, drawing - L<Imager::Draw/box>
3181
3182 color - L<Imager::Color>
3183
3184 color names - L<Imager::Color>, L<Imager::Color::Table>
3185
3186 combine modes - L<Imager::Fill/combine>
3187
3188 contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
3189
3190 convolution - L<Imager::Filter/conv>
3191
3192 cropping - L<Imager::Transformations/crop>
3193
3194 dpi - L<Imager::ImageTypes/i_xres>
3195
3196 drawing boxes - L<Imager::Draw/box>
3197
3198 drawing lines - L<Imager::Draw/line>
3199
3200 drawing text - L<Imager::Font/string>
3201
3202 error message - L<Imager/"Basic Overview">
3203
3204 files, font - L<Imager::Font>
3205
3206 files, image - L<Imager::Files>
3207
3208 filling, types of fill - L<Imager::Fill>
3209
3210 filling, boxes - L<Imager::Draw/box>
3211
3212 filling, flood fill - L<Imager::Draw/flood_fill>
3213
3214 flood fill - L<Imager::Draw/flood_fill>
3215
3216 fonts - L<Imager::Font>
3217
3218 fonts, drawing with - L<Imager::Font/string>, L<Imager::Font/align>,
3219 L<Imager::Font::Wrap>
3220
3221 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3222
3223 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
3224
3225 fountain fill - L<Imager::Fill/"Fountain fills">,
3226 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3227 L<Imager::Filters/gradgen>
3228
3229 GIF files - L<Imager::Files/"GIF">
3230
3231 GIF files, animated - L<Imager::File/"Writing an animated GIF">
3232
3233 gradient fill - L<Imager::Fill/"Fountain fills">,
3234 L<Imager::Filters/fountain>, L<Imager::Fountain>,
3235 L<Imager::Filters/gradgen>
3236
3237 guassian blur - L<Imager::Filter/guassian>
3238
3239 hatch fills - L<Imager::Fill/"Hatched fills">
3240
3241 invert image - L<Imager::Filter/hardinvert>
3242
3243 JPEG - L<Imager::Files/"JPEG">
3244
3245 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
3246
3247 lines, drawing - L<Imager::Draw/line>
3248
3249 matrix - L<Imager::Matrix2d>,
3250 L<Imager::Transformations/"Matrix Transformations">,
3251 L<Imager::Font/transform>
3252
3253 metadata, image - L<Imager::ImageTypes/"Tags">
3254
3255 mosaic - L<Imager::Filter/mosaic>
3256
3257 noise, filter - L<Imager::Filter/noise>
3258
3259 noise, rendered - L<Imager::Filter/turbnoise>,
3260 L<Imager::Filter/radnoise>
3261
3262 posterize - L<Imager::Filter/postlevels>
3263
3264 png files - L<Imager::Files>, L<Imager::Files/"PNG">
3265
3266 pnm - L<Imager::Files/"PNM (Portable aNy Map)">
3267
3268 rectangles, drawing - L<Imager::Draw/box>
3269
3270 resizing an image - L<Imager::Transformations/scale>,
3271 L<Imager::Transformations/crop>
3272
3273 saving an image - L<Imager::Files>
3274
3275 scaling - L<Imager::Transformations/scale>
3276
3277 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
3278
3279 size, image - L<Imager::ImageTypes/getwidth>,
3280 L<Imager::ImageTypes/getheight>
3281
3282 size, text - L<Imager::Font/bounding_box>
3283
3284 text, drawing - L<Imager::Font/string>, L<Imager::Font/align>,
3285 L<Imager::Font::Wrap>
3286
3287 text, wrapping text in an area - L<Imager::Font::Wrap>
3288
3289 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3290
3291 tiles, color - L<Imager::Filter/mosaic>
3292
3293 unsharp mask - L<Imager::Filter/unsharpmask>
3294
3295 watermark - L<Imager::Filter/watermark>
3296
3297 writing an image - L<Imager::Files>
3298
3299 =head1 SUPPORT
3300
3301 You can ask for help, report bugs or express your undying love for
3302 Imager on the Imager-devel mailing list.
3303
3304 To subscribe send a message with C<subscribe> in the body to:
3305
3306    imager-devel+request@molar.is
3307
3308 or use the form at:
3309
3310    http://www.molar.is/en/lists/imager-devel/
3311    (annonymous is temporarily off due to spam)
3312
3313 where you can also find the mailing list archive.
3314
3315 If you're into IRC, you can typically find the developers in #Imager
3316 on irc.perl.org.  As with any IRC channel, the participants could be
3317 occupied or asleep, so please be patient.
3318
3319 You can report bugs by pointing your browser at:
3320
3321   https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager
3322
3323 Please remember to include the versions of Imager, perl, supporting
3324 libraries, and any relevant code.  If you have specific images that
3325 cause the problems, please include those too.
3326
3327 =head1 BUGS
3328
3329 Bugs are listed individually for relevant pod pages.
3330
3331 =head1 AUTHOR
3332
3333 Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
3334 (tony@imager.perl.org) See the README for a complete list.
3335
3336 =head1 SEE ALSO
3337
3338 perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
3339 Imager::Color(3), Imager::Fill(3), Imager::Font(3),
3340 Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
3341 Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
3342
3343 Affix::Infix2Postfix(3), Parse::RecDescent(3)
3344 http://imager.perl.org/
3345
3346 =cut