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