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