Imager.pm

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