Imager.pm

   1 package Imager;
   2
   3
   4
   5 use strict;
   6 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS);
   7 use IO::File;
   8
   9 use Imager::Color;
  10 use Imager::Font;
  11
  12 @EXPORT_OK = qw(
  13                 init
  14                 init_log
  15                 DSO_open
  16                 DSO_close
  17                 DSO_funclist
  18                 DSO_call
  19
  20                 load_plugin
  21                 unload_plugin
  22
  23                 i_list_formats
  24                 i_has_format
  25
  26                 i_color_new
  27                 i_color_set
  28                 i_color_info
  29
  30                 i_img_empty
  31                 i_img_empty_ch
  32                 i_img_exorcise
  33                 i_img_destroy
  34
  35                 i_img_info
  36
  37                 i_img_setmask
  38                 i_img_getmask
  39
  40                 i_draw
  41                 i_line_aa
  42                 i_box
  43                 i_box_filled
  44                 i_arc
  45                 i_circle_aa
  46
  47                 i_bezier_multi
  48                 i_poly_aa
  49
  50                 i_copyto
  51                 i_rubthru
  52                 i_scaleaxis
  53                 i_scale_nn
  54                 i_haar
  55                 i_count_colors
  56
  57
  58                 i_gaussian
  59                 i_conv
  60
  61                 i_convert
  62                 i_map
  63
  64                 i_img_diff
  65
  66                 i_init_fonts
  67                 i_t1_new
  68                 i_t1_destroy
  69                 i_t1_set_aa
  70                 i_t1_cp
  71                 i_t1_text
  72                 i_t1_bbox
  73
  74
  75                 i_tt_set_aa
  76                 i_tt_cp
  77                 i_tt_text
  78                 i_tt_bbox
  79
  80                 i_readjpeg
  81                 i_writejpeg
  82
  83                 i_readjpeg_wiol
  84                 i_writejpeg_wiol
  85
  86                 i_readtiff_wiol
  87                 i_writetiff_wiol
  88                 i_writetiff_wiol_faxable
  89
  90                 i_readpng
  91                 i_writepng
  92
  93                 i_readgif
  94                 i_readgif_callback
  95                 i_writegif
  96                 i_writegifmc
  97                 i_writegif_gen
  98                 i_writegif_callback
  99
 100                 i_readpnm_wiol
 101                 i_writeppm
 102
 103                 i_readraw
 104                 i_writeraw
 105
 106                 i_contrast
 107                 i_hardinvert
 108                 i_noise
 109                 i_bumpmap
 110                 i_postlevels
 111                 i_mosaic
 112                 i_watermark
 113
 114                 malloc_state
 115
 116                 list_formats
 117
 118                 i_gifquant
 119
 120                 newfont
 121                 newcolor
 122                 newcolour
 123                 NC
 124                 NF
 125
 126 );
 127
 128
 129
 130 @EXPORT=qw(
 131            init_log
 132            i_list_formats
 133            i_has_format
 134            malloc_state
 135            i_color_new
 136
 137            i_img_empty
 138            i_img_empty_ch
 139           );
 140
 141 %EXPORT_TAGS=
 142   (handy => [qw(
 143                 newfont
 144                 newcolor
 145                 NF
 146                 NC
 147                )],
 148    all => [@EXPORT_OK],
 149    default => [qw(
 150                   load_plugin
 151                   unload_plugin
 152                  )]);
 153
 154
 155 BEGIN {
 156   require Exporter;
 157   require DynaLoader;
 158
 159   $VERSION = '0.38';
 160   @ISA = qw(Exporter DynaLoader);
 161   bootstrap Imager $VERSION;
 162 }
 163
 164 BEGIN {
 165   i_init_fonts(); # Initialize font engines
 166   for(i_list_formats()) { $formats{$_}++; }
 167
 168   if ($formats{'t1'}) {
 169     i_t1_set_aa(1);
 170   }
 171
 172   if (!$formats{'t1'} and !$formats{'tt'}) {
 173     $fontstate='no font support';
 174   }
 175
 176   %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
 177
 178   $DEBUG=0;
 179
 180   $filters{contrast}={
 181                       callseq => ['image','intensity'],
 182                       callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
 183                      };
 184
 185   $filters{noise} ={
 186                     callseq => ['image', 'amount', 'subtype'],
 187                     defaults => { amount=>3,subtype=>0 },
 188                     callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
 189                    };
 190
 191   $filters{hardinvert} ={
 192                          callseq => ['image'],
 193                          defaults => { },
 194                          callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
 195                         };
 196
 197   $filters{autolevels} ={
 198                          callseq => ['image','lsat','usat','skew'],
 199                          defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
 200                          callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
 201                         };
 202
 203   $filters{turbnoise} ={
 204                         callseq => ['image'],
 205                         defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
 206                         callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
 207                        };
 208
 209   $filters{radnoise} ={
 210                        callseq => ['image'],
 211                        defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
 212                        callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
 213                       };
 214
 215   $filters{conv} ={
 216                        callseq => ['image', 'coef'],
 217                        defaults => { },
 218                        callsub => sub { my %hsh=@_; i_conv($hsh{image},$hsh{coef}); }
 219                       };
 220
 221   $filters{gradgen} ={
 222                        callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 223                        defaults => { },
 224                        callsub => sub { my %hsh=@_; i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, $hsh{colors}, $hsh{dist}); }
 225                       };
 226
 227   $filters{nearest_color} ={
 228                             callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 229                             defaults => { },
 230                             callsub => sub { my %hsh=@_; i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, $hsh{colors}, $hsh{dist}); }
 231                            };
 232
 233   $FORMATGUESS=\&def_guess_type;
 234 }
 235
 236 #
 237 # Non methods
 238 #
 239
 240 # initlize Imager
 241 # NOTE: this might be moved to an import override later on
 242
 243 #sub import {
 244 #  my $pack = shift;
 245 #  (look through @_ for special tags, process, and remove them);
 246 #  use Data::Dumper;
 247 #  print Dumper($pack);
 248 #  print Dumper(@_);
 249 #}
 250
 251 sub init {
 252   my %parms=(loglevel=>1,@_);
 253   if ($parms{'log'}) {
 254     init_log($parms{'log'},$parms{'loglevel'});
 255   }
 256
 257 #    if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
 258 #    if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
 259 #       i_init_fonts();
 260 #       $fontstate='ok';
 261 #    }
 262 }
 263
 264 END {
 265   if ($DEBUG) {
 266     print "shutdown code\n";
 267     #   for(keys %instances) { $instances{$_}->DESTROY(); }
 268     malloc_state(); # how do decide if this should be used? -- store something from the import
 269     print "Imager exiting\n";
 270   }
 271 }
 272
 273 # Load a filter plugin
 274
 275 sub load_plugin {
 276   my ($filename)=@_;
 277   my $i;
 278   my ($DSO_handle,$str)=DSO_open($filename);
 279   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
 280   my %funcs=DSO_funclist($DSO_handle);
 281   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
 282   $i=0;
 283   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
 284
 285   $DSOs{$filename}=[$DSO_handle,\%funcs];
 286
 287   for(keys %funcs) {
 288     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
 289     $DEBUG && print "eval string:\n",$evstr,"\n";
 290     eval $evstr;
 291     print $@ if $@;
 292   }
 293   return 1;
 294 }
 295
 296 # Unload a plugin
 297
 298 sub unload_plugin {
 299   my ($filename)=@_;
 300
 301   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
 302   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
 303   for(keys %{$funcref}) {
 304     delete $filters{$_};
 305     $DEBUG && print "unloading: $_\n";
 306   }
 307   my $rc=DSO_close($DSO_handle);
 308   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
 309   return 1;
 310 }
 311
 312 # take the results of i_error() and make a message out of it
 313 sub _error_as_msg {
 314   return join(": ", map $_->[0], i_errors());
 315 }
 316
 317
 318 #
 319 # Methods to be called on objects.
 320 #
 321
 322 # Create a new Imager object takes very few parameters.
 323 # usually you call this method and then call open from
 324 # the resulting object
 325
 326 sub new {
 327   my $class = shift;
 328   my $self ={};
 329   my %hsh=@_;
 330   bless $self,$class;
 331   $self->{IMG}=undef;    # Just to indicate what exists
 332   $self->{ERRSTR}=undef; #
 333   $self->{DEBUG}=$DEBUG;
 334   $self->{DEBUG} && print "Initialized Imager\n";
 335   if ($hsh{xsize} && $hsh{ysize}) { $self->img_set(%hsh); }
 336   return $self;
 337 }
 338
 339
 340 # Copy an entire image with no changes
 341 # - if an image has magic the copy of it will not be magical
 342
 343 sub copy {
 344   my $self = shift;
 345   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 346
 347   my $newcopy=Imager->new();
 348   $newcopy->{IMG}=i_img_new();
 349   i_copy($newcopy->{IMG},$self->{IMG});
 350   return $newcopy;
 351 }
 352
 353 # Paste a region
 354
 355 sub paste {
 356   my $self = shift;
 357   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 358   my %input=(left=>0, top=>0, @_);
 359   unless($input{img}) {
 360     $self->{ERRSTR}="no source image";
 361     return;
 362   }
 363   $input{left}=0 if $input{left} <= 0;
 364   $input{top}=0 if $input{top} <= 0;
 365   my $src=$input{img};
 366   my($r,$b)=i_img_info($src->{IMG});
 367
 368   i_copyto($self->{IMG}, $src->{IMG},
 369            0,0, $r, $b, $input{left}, $input{top});
 370   return $self;  # What should go here??
 371 }
 372
 373 # Crop an image - i.e. return a new image that is smaller
 374
 375 sub crop {
 376   my $self=shift;
 377   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 378   my %hsh=(left=>0,right=>0,top=>0,bottom=>0,@_);
 379
 380   my ($w,$h,$l,$r,$b,$t)=($self->getwidth(),$self->getheight(),
 381                                 @hsh{qw(left right bottom top)});
 382   $l=0 if not defined $l;
 383   $t=0 if not defined $t;
 384
 385   $r||=$l+delete $hsh{'width'}    if defined $l and exists $hsh{'width'};
 386   $b||=$t+delete $hsh{'height'}   if defined $t and exists $hsh{'height'};
 387   $l||=$r-delete $hsh{'width'}    if defined $r and exists $hsh{'width'};
 388   $t||=$b-delete $hsh{'height'}   if defined $b and exists $hsh{'height'};
 389
 390   $r=$self->getwidth if not defined $r;
 391   $b=$self->getheight if not defined $b;
 392
 393   ($l,$r)=($r,$l) if $l>$r;
 394   ($t,$b)=($b,$t) if $t>$b;
 395
 396   if ($hsh{'width'}) {
 397     $l=int(0.5+($w-$hsh{'width'})/2);
 398     $r=$l+$hsh{'width'};
 399   } else {
 400     $hsh{'width'}=$r-$l;
 401   }
 402   if ($hsh{'height'}) {
 403     $b=int(0.5+($h-$hsh{'height'})/2);
 404     $t=$h+$hsh{'height'};
 405   } else {
 406     $hsh{'height'}=$b-$t;
 407   }
 408
 409 #    print "l=$l, r=$r, h=$hsh{'width'}\n";
 410 #    print "t=$t, b=$b, w=$hsh{'height'}\n";
 411
 412   my $dst=Imager->new(xsize=>$hsh{'width'}, ysize=>$hsh{'height'}, channels=>$self->getchannels());
 413
 414   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
 415   return $dst;
 416 }
 417
 418 # Sets an image to a certain size and channel number
 419 # if there was previously data in the image it is discarded
 420
 421 sub img_set {
 422   my $self=shift;
 423
 424   my %hsh=(xsize=>100,ysize=>100,channels=>3,@_);
 425
 426   if (defined($self->{IMG})) {
 427     i_img_destroy($self->{IMG});
 428     undef($self->{IMG});
 429   }
 430
 431   $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'},$hsh{'ysize'},$hsh{'channels'});
 432 }
 433
 434 # Read an image from file
 435
 436 sub read {
 437   my $self = shift;
 438   my %input=@_;
 439   my ($fh, $fd, $IO);
 440
 441   if (defined($self->{IMG})) {
 442     i_img_destroy($self->{IMG});
 443     undef($self->{IMG});
 444   }
 445
 446   if (!$input{fd} and !$input{file} and !$input{data}) { $self->{ERRSTR}='no file, fd or data parameter'; return undef; }
 447   if ($input{file}) {
 448     $fh = new IO::File($input{file},"r");
 449     if (!defined $fh) { $self->{ERRSTR}='Could not open file'; return undef; }
 450     binmode($fh);
 451     $fd = $fh->fileno();
 452   }
 453   if ($input{fd}) { $fd=$input{fd} };
 454
 455   # FIXME: Find the format here if not specified
 456   # yes the code isn't here yet - next week maybe?
 457
 458   if (!$input{type} and $input{file}) { $input{type}=$FORMATGUESS->($input{file}); }
 459   if (!$formats{$input{type}}) { $self->{ERRSTR}='format not supported'; return undef; }
 460
 461   my %iolready=(jpeg=>1, tiff=>1, pnm=>1);
 462
 463   if ($iolready{$input{type}}) {
 464     # Setup data source
 465     $IO = io_new_fd($fd); # sort of simple for now eh?
 466
 467     if ( $input{type} eq 'jpeg' ) {
 468       ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_wiol( $IO );
 469       if ( !defined($self->{IMG}) ) { $self->{ERRSTR}='unable to read jpeg image'; return undef; }
 470       $self->{DEBUG} && print "loading a jpeg file\n";
 471       return $self;
 472     }
 473
 474     if ( $input{type} eq 'tiff' ) {
 475       $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
 476       if ( !defined($self->{IMG}) ) { $self->{ERRSTR}='unable to read tiff image'; return undef; }
 477       $self->{DEBUG} && print "loading a tiff file\n";
 478       return $self;
 479     }
 480
 481     if ( $input{type} eq 'pnm' ) {
 482       $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
 483       if ( !defined($self->{IMG}) ) { $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef; }
 484       $self->{DEBUG} && print "loading a pnm file\n";
 485       return $self;
 486     }
 487
 488   } else {
 489
 490   # Old code for reference while changing the new stuff
 491
 492
 493   if (!$input{type} and $input{file}) { $input{type}=$FORMATGUESS->($input{file}); }
 494   if (!$input{type}) { $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef; }
 495
 496   if (!$formats{$input{type}}) { $self->{ERRSTR}='format not supported'; return undef; }
 497
 498   if ($input{file}) {
 499     $fh = new IO::File($input{file},"r");
 500     if (!defined $fh) { $self->{ERRSTR}='Could not open file'; return undef; }
 501     binmode($fh);
 502     $fd = $fh->fileno();
 503   }
 504   if ($input{fd}) { $fd=$input{fd} };
 505
 506   if ( $input{type} eq 'gif' ) {
 507     my $colors;
 508     if ($input{colors} && !ref($input{colors})) {
 509       # must be a reference to a scalar that accepts the colour map
 510       $self->{ERRSTR} = "option 'colors' must be a scalar reference";
 511       return undef;
 512     }
 513     if (exists $input{data}) {
 514       if ($input{colors}) {
 515         ($self->{IMG}, $colors) = i_readgif_scalar($input{data});
 516       }
 517       else {
 518         $self->{IMG}=i_readgif_scalar($input{data});
 519       }
 520     }
 521     else {
 522       if ($input{colors}) {
 523         ($self->{IMG}, $colors) = i_readgif( $fd );
 524       }
 525       else {
 526         $self->{IMG} = i_readgif( $fd )
 527       }
 528     }
 529     if ($colors) {
 530       # we may or may not change i_readgif to return blessed objects...
 531       ${$input{colors}} = [ map { NC(@$_) } @$colors ];
 532     }
 533     if ( !defined($self->{IMG}) ) {
 534       $self->{ERRSTR}= 'reading GIF:'._error_as_msg(); return undef;
 535     }
 536     $self->{DEBUG} && print "loading a gif file\n";
 537   } elsif ( $input{type} eq 'jpeg' ) {
 538     if (exists $input{data}) { ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_scalar($input{data}); }
 539     else { ($self->{IMG},$self->{IPTCRAW})=i_readjpeg( $fd ); }
 540     if ( !defined($self->{IMG}) ) { $self->{ERRSTR}='unable to read jpeg image'; return undef; }
 541     $self->{DEBUG} && print "loading a jpeg file\n";
 542   } elsif ( $input{type} eq 'png' ) {
 543     if (exists $input{data}) { $self->{IMG}=i_readpng_scalar($input{data}); }
 544     else { $self->{IMG}=i_readpng( $fd ); }
 545     if ( !defined($self->{IMG}) ) { $self->{ERRSTR}='unable to read png image'; return undef; }
 546     $self->{DEBUG} && print "loading a png file\n";
 547   } elsif ( $input{type} eq 'raw' ) {
 548     my %params=(datachannels=>3,storechannels=>3,interleave=>1);
 549     for(keys(%input)) { $params{$_}=$input{$_}; }
 550
 551     if ( !($params{xsize} && $params{ysize}) ) { $self->{ERRSTR}='missing xsize or ysize parameter for raw'; return undef; }
 552     $self->{IMG}=i_readraw( $fd, $params{xsize}, $params{ysize},
 553                            $params{datachannels}, $params{storechannels}, $params{interleave});
 554     if ( !defined($self->{IMG}) ) { $self->{ERRSTR}='unable to read raw image'; return undef; }
 555     $self->{DEBUG} && print "loading a raw file\n";
 556   }
 557   return $self;
 558   }
 559 }
 560
 561
 562 # Write an image to file
 563
 564 sub write {
 565   my $self = shift;
 566   my %input=(jpegquality=>75, gifquant=>'mc', lmdither=>6.0, lmfixed=>[],
 567              fax_fine=>1, @_);
 568   my ($fh, $rc, $fd, $IO);
 569
 570   my %iolready=( tiff=>1 ); # this will be SO MUCH BETTER once they are all in there
 571
 572   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 573
 574   if (!$input{file} and !$input{'fd'} and !$input{'data'}) { $self->{ERRSTR}='file/fd/data parameter missing'; return undef; }
 575   if (!$input{type} and $input{file}) { $input{type}=$FORMATGUESS->($input{file}); }
 576   if (!$input{type}) { $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef; }
 577
 578   if (!$formats{$input{type}}) { $self->{ERRSTR}='format not supported'; return undef; }
 579
 580   if (exists $input{'fd'}) {
 581     $fd=$input{'fd'};
 582   } elsif (exists $input{'data'}) {
 583     $IO = Imager::io_new_bufchain();
 584   } else {
 585     $fh = new IO::File($input{file},"w+");
 586     if (!defined $fh) { $self->{ERRSTR}='Could not open file'; return undef; }
 587     binmode($fh);
 588     $fd = $fh->fileno();
 589   }
 590
 591
 592
 593   if ($iolready{$input{type}}) {
 594     if (defined $fd) {
 595       $IO = io_new_fd($fd);
 596     }
 597
 598     if ($input{type} eq 'tiff') {
 599       if (defined $input{class} && $input{class} eq 'fax') {
 600         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
 601           $self->{ERRSTR}='Could not write to buffer';
 602           return undef;
 603         }
 604       }
 605       else {
 606         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
 607           $self->{ERRSTR}='Could not write to buffer';
 608           return undef;
 609         }
 610       }
 611     }
 612
 613     if (exists $input{'data'}) {
 614       my $data = io_slurp($IO);
 615       if (!$data) {
 616         $self->{ERRSTR}='Could not slurp from buffer';
 617         return undef;
 618       }
 619       ${$input{data}} = $data;
 620     }
 621     return $self;
 622   } else {
 623
 624     if ( $input{type} eq 'gif' ) {
 625       if (not $input{gifplanes}) {
 626         my $gp;
 627         my $count=i_count_colors($self->{IMG}, 256);
 628         $gp=8 if $count == -1;
 629         $gp=1 if not $gp and $count <= 2;
 630         $gp=2 if not $gp and $count <= 4;
 631         $gp=3 if not $gp and $count <= 8;
 632         $gp=4 if not $gp and $count <= 16;
 633         $gp=5 if not $gp and $count <= 32;
 634         $gp=6 if not $gp and $count <= 64;
 635         $gp=7 if not $gp and $count <= 128;
 636         $input{gifplanes} = $gp || 8;
 637       }
 638
 639       if ($input{gifplanes}>8) {
 640         $input{gifplanes}=8;
 641       }
 642       if ($input{gifquant} eq 'gen' || $input{callback}) {
 643
 644
 645         if ($input{gifquant} eq 'lm') {
 646
 647           $input{make_colors} = 'addi';
 648           $input{translate} = 'perturb';
 649           $input{perturb} = $input{lmdither};
 650         } elsif ($input{gifquant} eq 'gen') {
 651           # just pass options through
 652         } else {
 653           $input{make_colors} = 'webmap'; # ignored
 654           $input{translate} = 'giflib';
 655         }
 656
 657         if ($input{callback}) {
 658           defined $input{maxbuffer} or $input{maxbuffer} = -1;
 659           $rc = i_writegif_callback($input{callback}, $input{maxbuffer},
 660                                     \%input, $self->{IMG});
 661         } else {
 662           $rc = i_writegif_gen($fd, \%input, $self->{IMG});
 663         }
 664
 665
 666
 667       } elsif ($input{gifquant} eq 'lm') {
 668         $rc=i_writegif($self->{IMG},$fd,$input{gifplanes},$input{lmdither},$input{lmfixed});
 669       } else {
 670         $rc=i_writegifmc($self->{IMG},$fd,$input{gifplanes});
 671       }
 672       if ( !defined($rc) ) {
 673         $self->{ERRSTR} = "Writing GIF file: "._error_as_msg(); return undef;
 674       }
 675       $self->{DEBUG} && print "writing a gif file\n";
 676
 677     } elsif ( $input{type} eq 'jpeg' ) {
 678       $rc=i_writejpeg($self->{IMG},$fd,$input{jpegquality});
 679       if ( !defined($rc) ) {
 680         $self->{ERRSTR}='unable to write jpeg image'; return undef;
 681       }
 682       $self->{DEBUG} && print "writing a jpeg file\n";
 683     } elsif ( $input{type} eq 'png' ) {
 684       $rc=i_writepng($self->{IMG},$fd);
 685       if ( !defined($rc) ) {
 686         $self->{ERRSTR}='unable to write png image'; return undef;
 687       }
 688       $self->{DEBUG} && print "writing a png file\n";
 689     } elsif ( $input{type} eq 'pnm' ) {
 690       $rc=i_writeppm($self->{IMG},$fd);
 691       if ( !defined($rc) ) {
 692         $self->{ERRSTR}='unable to write pnm image'; return undef;
 693       }
 694       $self->{DEBUG} && print "writing a pnm file\n";
 695     } elsif ( $input{type} eq 'raw' ) {
 696       $rc=i_writeraw($self->{IMG},$fd);
 697       if ( !defined($rc) ) {
 698         $self->{ERRSTR}='unable to write raw image'; return undef;
 699       }
 700       $self->{DEBUG} && print "writing a raw file\n";
 701     }
 702
 703   }
 704   return $self;
 705 }
 706
 707 sub write_multi {
 708   my ($class, $opts, @images) = @_;
 709
 710   if ($opts->{type} eq 'gif') {
 711     my $gif_delays = $opts->{gif_delays};
 712     local $opts->{gif_delays} = $gif_delays;
 713     unless (ref $opts->{gif_delays}) {
 714       # assume the caller wants the same delay for each frame
 715       $opts->{gif_delays} = [ ($gif_delays) x @images ];
 716     }
 717     # translate to ImgRaw
 718     if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
 719       $ERRSTR = "Usage: Imager->write_multi({ options }, @images)";
 720       return 0;
 721     }
 722     my @work = map $_->{IMG}, @images;
 723     if ($opts->{callback}) {
 724       # Note: you may need to fix giflib for this one to work
 725       my $maxbuffer = $opts->{maxbuffer};
 726       defined $maxbuffer or $maxbuffer = -1; # max by default
 727       return i_writegif_callback($opts->{callback}, $maxbuffer,
 728                                  $opts, @work);
 729     }
 730     if ($opts->{fd}) {
 731       return i_writegif_gen($opts->{fd}, $opts, @work);
 732     }
 733     else {
 734       my $fh = IO::File->new($opts->{file}, "w+");
 735       unless ($fh) {
 736         $ERRSTR = "Error creating $opts->{file}: $!";
 737         return 0;
 738       }
 739       binmode($fh);
 740       return i_writegif_gen(fileno($fh), $opts, @work);
 741     }
 742   }
 743   else {
 744     $ERRSTR = "Sorry, write_multi doesn't support $opts->{type} yet";
 745     return 0;
 746   }
 747 }
 748
 749 # Destroy an Imager object
 750
 751 sub DESTROY {
 752   my $self=shift;
 753   #    delete $instances{$self};
 754   if (defined($self->{IMG})) {
 755     i_img_destroy($self->{IMG});
 756     undef($self->{IMG});
 757   } else {
 758 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
 759   }
 760 }
 761
 762 # Perform an inplace filter of an image
 763 # that is the image will be overwritten with the data
 764
 765 sub filter {
 766   my $self=shift;
 767   my %input=@_;
 768   my %hsh;
 769   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 770
 771   if (!$input{type}) { $self->{ERRSTR}='type parameter missing'; return undef; }
 772
 773   if ( (grep { $_ eq $input{type} } keys %filters) != 1) {
 774     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
 775   }
 776
 777   if (defined($filters{$input{type}}{defaults})) {
 778     %hsh=('image',$self->{IMG},%{$filters{$input{type}}{defaults}},%input);
 779   } else {
 780     %hsh=('image',$self->{IMG},%input);
 781   }
 782
 783   my @cs=@{$filters{$input{type}}{callseq}};
 784
 785   for(@cs) {
 786     if (!defined($hsh{$_})) {
 787       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{type}; return undef;
 788     }
 789   }
 790
 791   &{$filters{$input{type}}{callsub}}(%hsh);
 792
 793   my @b=keys %hsh;
 794
 795   $self->{DEBUG} && print "callseq is: @cs\n";
 796   $self->{DEBUG} && print "matching callseq is: @b\n";
 797
 798   return $self;
 799 }
 800
 801 # Scale an image to requested size and return the scaled version
 802
 803 sub scale {
 804   my $self=shift;
 805   my %opts=(scalefactor=>0.5,type=>'max',qtype=>'normal',@_);
 806   my $img = Imager->new();
 807   my $tmp = Imager->new();
 808
 809   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 810
 811   if ($opts{xpixels} and $opts{ypixels} and $opts{type}) {
 812     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
 813     if ($opts{type} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
 814     if ($opts{type} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
 815   } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
 816   elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
 817
 818   if ($opts{qtype} eq 'normal') {
 819     $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
 820     if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
 821     $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
 822     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
 823     return $img;
 824   }
 825   if ($opts{'qtype'} eq 'preview') {
 826     $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
 827     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
 828     return $img;
 829   }
 830   $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
 831 }
 832
 833 # Scales only along the X axis
 834
 835 sub scaleX {
 836   my $self=shift;
 837   my %opts=(scalefactor=>0.5,@_);
 838
 839   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 840
 841   my $img = Imager->new();
 842
 843   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
 844
 845   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 846   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
 847
 848   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
 849   return $img;
 850 }
 851
 852 # Scales only along the Y axis
 853
 854 sub scaleY {
 855   my $self=shift;
 856   my %opts=(scalefactor=>0.5,@_);
 857
 858   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 859
 860   my $img = Imager->new();
 861
 862   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
 863
 864   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 865   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
 866
 867   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
 868   return $img;
 869 }
 870
 871
 872 # Transform returns a spatial transformation of the input image
 873 # this moves pixels to a new location in the returned image.
 874 # NOTE - should make a utility function to check transforms for
 875 # stack overruns
 876
 877 sub transform {
 878   my $self=shift;
 879   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 880   my %opts=@_;
 881   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
 882
 883 #  print Dumper(\%opts);
 884 #  xopcopdes
 885
 886   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
 887     if (!$I2P) {
 888       eval ("use Affix::Infix2Postfix;");
 889       print $@;
 890       if ( $@ ) {
 891         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
 892         return undef;
 893       }
 894       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
 895                                              {op=>'-',trans=>'Sub'},
 896                                              {op=>'*',trans=>'Mult'},
 897                                              {op=>'/',trans=>'Div'},
 898                                              {op=>'-',type=>'unary',trans=>'u-'},
 899                                              {op=>'**'},
 900                                              {op=>'func',type=>'unary'}],
 901                                      'grouping'=>[qw( \( \) )],
 902                                      'func'=>[qw( sin cos )],
 903                                      'vars'=>[qw( x y )]
 904                                     );
 905     }
 906
 907     @xt=$I2P->translate($opts{'xexpr'});
 908     @yt=$I2P->translate($opts{'yexpr'});
 909
 910     $numre=$I2P->{'numre'};
 911     @pt=(0,0);
 912
 913     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
 914     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
 915     @{$opts{'parm'}}=@pt;
 916   }
 917
 918 #  print Dumper(\%opts);
 919
 920   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
 921     $self->{ERRSTR}='transform: no xopcodes given.';
 922     return undef;
 923   }
 924
 925   @op=@{$opts{'xopcodes'}};
 926   for $iop (@op) {
 927     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
 928       $self->{ERRSTR}="transform: illegal opcode '$_'.";
 929       return undef;
 930     }
 931     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
 932   }
 933
 934
 935 # yopcopdes
 936
 937   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
 938     $self->{ERRSTR}='transform: no yopcodes given.';
 939     return undef;
 940   }
 941
 942   @op=@{$opts{'yopcodes'}};
 943   for $iop (@op) {
 944     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
 945       $self->{ERRSTR}="transform: illegal opcode '$_'.";
 946       return undef;
 947     }
 948     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
 949   }
 950
 951 #parameters
 952
 953   if ( !exists $opts{'parm'}) {
 954     $self->{ERRSTR}='transform: no parameter arg given.';
 955     return undef;
 956   }
 957
 958 #  print Dumper(\@ropx);
 959 #  print Dumper(\@ropy);
 960 #  print Dumper(\@ropy);
 961
 962   my $img = Imager->new();
 963   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
 964   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
 965   return $img;
 966 }
 967
 968
 969 {
 970   my $got_expr;
 971   sub transform2 {
 972     my ($opts, @imgs) = @_;
 973
 974     if (!$got_expr) {
 975       # this is fairly big, delay loading it
 976       eval "use Imager::Expr";
 977       die $@ if $@;
 978       ++$got_expr;
 979     }
 980
 981     $opts->{variables} = [ qw(x y) ];
 982     my ($width, $height) = @{$opts}{qw(width height)};
 983     if (@imgs) {
 984         $width ||= $imgs[0]->getwidth();
 985         $height ||= $imgs[0]->getheight();
 986         my $img_num = 1;
 987         for my $img (@imgs) {
 988             $opts->{constants}{"w$img_num"} = $img->getwidth();
 989             $opts->{constants}{"h$img_num"} = $img->getheight();
 990             $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
 991             $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
 992             ++$img_num;
 993         }
 994     }
 995     if ($width) {
 996       $opts->{constants}{w} = $width;
 997       $opts->{constants}{cx} = $width/2;
 998     }
 999     else {
1000       $Imager::ERRSTR = "No width supplied";
1001       return;
1002     }
1003     if ($height) {
1004       $opts->{constants}{h} = $height;
1005       $opts->{constants}{cy} = $height/2;
1006     }
1007     else {
1008       $Imager::ERRSTR = "No height supplied";
1009       return;
1010     }
1011     my $code = Imager::Expr->new($opts);
1012     if (!$code) {
1013       $Imager::ERRSTR = Imager::Expr::error();
1014       return;
1015     }
1016
1017     my $img = Imager->new();
1018     $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, $code->code(),
1019                                $code->nregs(), $code->cregs(),
1020                                [ map { $_->{IMG} } @imgs ]);
1021     if (!defined $img->{IMG}) {
1022       $Imager::ERRSTR = "transform2 failed";
1023       return;
1024     }
1025
1026     return $img;
1027   }
1028 }
1029
1030
1031
1032
1033
1034
1035
1036
1037 sub rubthrough {
1038   my $self=shift;
1039   my %opts=(tx=>0,ty=>0,@_);
1040
1041   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1042   unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1043
1044   i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx},$opts{ty});
1045   return $self;
1046 }
1047
1048
1049 sub flip {
1050   my $self  = shift;
1051   my %opts  = @_;
1052   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
1053   my $dir;
1054   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1055   $dir = $xlate{$opts{'dir'}};
1056   return $self if i_flipxy($self->{IMG}, $dir);
1057   return ();
1058 }
1059
1060
1061
1062 # These two are supported for legacy code only
1063
1064 sub i_color_new {
1065   return Imager::Color->new($_[0], $_[1], $_[2], $_[3]);
1066 }
1067
1068 sub i_color_set {
1069   return Imager::Color::set($_[0], $_[1], $_[2], $_[3], $_[4]);
1070 }
1071
1072
1073
1074 # Draws a box between the specified corner points.
1075
1076 sub box {
1077   my $self=shift;
1078   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1079   my $dflcl=i_color_new(255,255,255,255);
1080   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1081
1082   if (exists $opts{'box'}) {
1083     $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1084     $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1085     $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1086     $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1087   }
1088
1089   if ($opts{filled}) { i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},$opts{color}); }
1090   else { i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},$opts{color}); }
1091   return $self;
1092 }
1093
1094 # Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
1095
1096 sub arc {
1097   my $self=shift;
1098   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1099   my $dflcl=i_color_new(255,255,255,255);
1100   my %opts=(color=>$dflcl,
1101             'r'=>min($self->getwidth(),$self->getheight())/3,
1102             'x'=>$self->getwidth()/2,
1103             'y'=>$self->getheight()/2,
1104             'd1'=>0, 'd2'=>361, @_);
1105   i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},$opts{'d2'},$opts{'color'});
1106   return $self;
1107 }
1108
1109 # Draws a line from one point to (but not including) the destination point
1110
1111 sub line {
1112   my $self=shift;
1113   my $dflcl=i_color_new(0,0,0,0);
1114   my %opts=(color=>$dflcl,@_);
1115   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1116
1117   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
1118   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
1119
1120   if ($opts{antialias}) {
1121     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2}, $opts{color});
1122   } else {
1123     i_draw($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2}, $opts{color});
1124   }
1125   return $self;
1126 }
1127
1128 # Draws a line between an ordered set of points - It more or less just transforms this
1129 # into a list of lines.
1130
1131 sub polyline {
1132   my $self=shift;
1133   my ($pt,$ls,@points);
1134   my $dflcl=i_color_new(0,0,0,0);
1135   my %opts=(color=>$dflcl,@_);
1136
1137   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1138
1139   if (exists($opts{points})) { @points=@{$opts{points}}; }
1140   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
1141     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
1142     }
1143
1144 #  print Dumper(\@points);
1145
1146   if ($opts{antialias}) {
1147     for $pt(@points) {
1148       if (defined($ls)) { i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$opts{color}); }
1149       $ls=$pt;
1150     }
1151   } else {
1152     for $pt(@points) {
1153       if (defined($ls)) { i_draw($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$opts{color}); }
1154       $ls=$pt;
1155     }
1156   }
1157   return $self;
1158 }
1159
1160 # this the multipoint bezier curve
1161 # this is here more for testing that actual usage since
1162 # this is not a good algorithm.  Usually the curve would be
1163 # broken into smaller segments and each done individually.
1164
1165 sub polybezier {
1166   my $self=shift;
1167   my ($pt,$ls,@points);
1168   my $dflcl=i_color_new(0,0,0,0);
1169   my %opts=(color=>$dflcl,@_);
1170
1171   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1172
1173   if (exists $opts{points}) {
1174     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
1175     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
1176   }
1177
1178   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
1179     $self->{ERRSTR}='Missing or invalid points.';
1180     return;
1181   }
1182
1183   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$opts{'color'});
1184   return $self;
1185 }
1186
1187 # make an identity matrix of the given size
1188 sub _identity {
1189   my ($size) = @_;
1190
1191   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
1192   for my $c (0 .. ($size-1)) {
1193     $matrix->[$c][$c] = 1;
1194   }
1195   return $matrix;
1196 }
1197
1198 # general function to convert an image
1199 sub convert {
1200   my ($self, %opts) = @_;
1201   my $matrix;
1202
1203   # the user can either specify a matrix or preset
1204   # the matrix overrides the preset
1205   if (!exists($opts{matrix})) {
1206     unless (exists($opts{preset})) {
1207       $self->{ERRSTR} = "convert() needs a matrix or preset";
1208       return;
1209     }
1210     else {
1211       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
1212         # convert to greyscale, keeping the alpha channel if any
1213         if ($self->getchannels == 3) {
1214           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
1215         }
1216         elsif ($self->getchannels == 4) {
1217           # preserve the alpha channel
1218           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
1219                       [ 0,     0,     0,     1 ] ];
1220         }
1221         else {
1222           # an identity
1223           $matrix = _identity($self->getchannels);
1224         }
1225       }
1226       elsif ($opts{preset} eq 'noalpha') {
1227         # strip the alpha channel
1228         if ($self->getchannels == 2 or $self->getchannels == 4) {
1229           $matrix = _identity($self->getchannels);
1230           pop(@$matrix); # lose the alpha entry
1231         }
1232         else {
1233           $matrix = _identity($self->getchannels);
1234         }
1235       }
1236       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
1237         # extract channel 0
1238         $matrix = [ [ 1 ] ];
1239       }
1240       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
1241         $matrix = [ [ 0, 1 ] ];
1242       }
1243       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
1244         $matrix = [ [ 0, 0, 1 ] ];
1245       }
1246       elsif ($opts{preset} eq 'alpha') {
1247         if ($self->getchannels == 2 or $self->getchannels == 4) {
1248           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
1249         }
1250         else {
1251           # the alpha is just 1 <shrug>
1252           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
1253         }
1254       }
1255       elsif ($opts{preset} eq 'rgb') {
1256         if ($self->getchannels == 1) {
1257           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
1258         }
1259         elsif ($self->getchannels == 2) {
1260           # preserve the alpha channel
1261           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
1262         }
1263         else {
1264           $matrix = _identity($self->getchannels);
1265         }
1266       }
1267       elsif ($opts{preset} eq 'addalpha') {
1268         if ($self->getchannels == 1) {
1269           $matrix = _identity(2);
1270         }
1271         elsif ($self->getchannels == 3) {
1272           $matrix = _identity(4);
1273         }
1274         else {
1275           $matrix = _identity($self->getchannels);
1276         }
1277       }
1278       else {
1279         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
1280         return undef;
1281       }
1282     }
1283   }
1284   else {
1285     $matrix = $opts{matrix};
1286   }
1287
1288   my $new = Imager->new();
1289   $new->{IMG} = i_img_new();
1290   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
1291     # most likely a bad matrix
1292     $self->{ERRSTR} = _error_as_msg();
1293     return undef;
1294   }
1295   return $new;
1296 }
1297
1298
1299 # general function to map an image through lookup tables
1300
1301 sub map {
1302   my ($self, %opts) = @_;
1303   my @chlist = qw( red green blue alpha );
1304
1305   if (!exists($opts{'maps'})) {
1306     # make maps from channel maps
1307     my $chnum;
1308     for $chnum (0..$#chlist) {
1309       if (exists $opts{$chlist[$chnum]}) {
1310         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
1311       } elsif (exists $opts{'all'}) {
1312         $opts{'maps'}[$chnum] = $opts{'all'};
1313       }
1314     }
1315   }
1316   if ($opts{'maps'} and $self->{IMG}) {
1317     i_map($self->{IMG}, $opts{'maps'} );
1318   }
1319   return $self;
1320 }
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333 # destructive border - image is shrunk by one pixel all around
1334
1335 sub border {
1336   my ($self,%opts)=@_;
1337   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
1338   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
1339 }
1340
1341
1342 # Get the width of an image
1343
1344 sub getwidth {
1345   my $self = shift;
1346   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
1347   return (i_img_info($self->{IMG}))[0];
1348 }
1349
1350 # Get the height of an image
1351
1352 sub getheight {
1353   my $self = shift;
1354   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
1355   return (i_img_info($self->{IMG}))[1];
1356 }
1357
1358 # Get number of channels in an image
1359
1360 sub getchannels {
1361   my $self = shift;
1362   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
1363   return i_img_getchannels($self->{IMG});
1364 }
1365
1366 # Get channel mask
1367
1368 sub getmask {
1369   my $self = shift;
1370   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
1371   return i_img_getmask($self->{IMG});
1372 }
1373
1374 # Set channel mask
1375
1376 sub setmask {
1377   my $self = shift;
1378   my %opts = @_;
1379   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
1380   i_img_setmask( $self->{IMG} , $opts{mask} );
1381 }
1382
1383 # Get number of colors in an image
1384
1385 sub getcolorcount {
1386   my $self=shift;
1387   my %opts=(maxcolors=>2**30,@_);
1388   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
1389   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
1390   return ($rc==-1? undef : $rc);
1391 }
1392
1393 # draw string to an image
1394
1395 sub string {
1396   my $self = shift;
1397   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1398
1399   my %input=('x'=>0, 'y'=>0, @_);
1400   $input{string}||=$input{text};
1401
1402   unless(exists $input{string}) {
1403     $self->{ERRSTR}="missing required parameter 'string'";
1404     return;
1405   }
1406
1407   unless($input{font}) {
1408     $self->{ERRSTR}="missing required parameter 'font'";
1409     return;
1410   }
1411
1412   $input{font}->draw(image=>$self, %input);
1413
1414   return $self;
1415 }
1416
1417
1418
1419
1420
1421 # Shortcuts that can be exported
1422
1423 sub newcolor { Imager::Color->new(@_); }
1424 sub newfont  { Imager::Font->new(@_); }
1425
1426 *NC=*newcolour=*newcolor;
1427 *NF=*newfont;
1428
1429 *open=\&read;
1430 *circle=\&arc;
1431
1432
1433 #### Utility routines
1434
1435 sub errstr { $_[0]->{ERRSTR} }
1436
1437
1438
1439
1440
1441
1442 # Default guess for the type of an image from extension
1443
1444 sub def_guess_type {
1445   my $name=lc(shift);
1446   my $ext;
1447   $ext=($name =~ m/\.([^\.]+)$/)[0];
1448   return 'tiff' if ($ext =~ m/^tiff?$/);
1449   return 'jpeg' if ($ext =~ m/^jpe?g$/);
1450   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
1451   return 'png'  if ($ext eq "png");
1452   return 'gif'  if ($ext eq "gif");
1453   return ();
1454 }
1455
1456 # get the minimum of a list
1457
1458 sub min {
1459   my $mx=shift;
1460   for(@_) { if ($_<$mx) { $mx=$_; }}
1461   return $mx;
1462 }
1463
1464 # get the maximum of a list
1465
1466 sub max {
1467   my $mx=shift;
1468   for(@_) { if ($_>$mx) { $mx=$_; }}
1469   return $mx;
1470 }
1471
1472 # string stuff for iptc headers
1473
1474 sub clean {
1475   my($str)=$_[0];
1476   $str = substr($str,3);
1477   $str =~ s/[\n\r]//g;
1478   $str =~ s/\s+/ /g;
1479   $str =~ s/^\s//;
1480   $str =~ s/\s$//;
1481   return $str;
1482 }
1483
1484 # A little hack to parse iptc headers.
1485
1486 sub parseiptc {
1487   my $self=shift;
1488   my(@sar,$item,@ar);
1489   my($caption,$photogr,$headln,$credit);
1490
1491   my $str=$self->{IPTCRAW};
1492
1493   #print $str;
1494
1495   @ar=split(/8BIM/,$str);
1496
1497   my $i=0;
1498   foreach (@ar) {
1499     if (/^\004\004/) {
1500       @sar=split(/\034\002/);
1501       foreach $item (@sar) {
1502         if ($item =~ m/^x/) {
1503           $caption=&clean($item);
1504           $i++;
1505         }
1506         if ($item =~ m/^P/) {
1507           $photogr=&clean($item);
1508           $i++;
1509         }
1510         if ($item =~ m/^i/) {
1511           $headln=&clean($item);
1512           $i++;
1513         }
1514         if ($item =~ m/^n/) {
1515           $credit=&clean($item);
1516           $i++;
1517         }
1518       }
1519     }
1520   }
1521   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
1522 }
1523
1524
1525
1526
1527
1528
1529 # Autoload methods go after =cut, and are processed by the autosplit program.
1530
1531 1;
1532 __END__
1533 # Below is the stub of documentation for your module. You better edit it!
1534
1535 =head1 NAME
1536
1537 Imager - Perl extension for Generating 24 bit Images
1538
1539 =head1 SYNOPSIS
1540
1541   use Imager qw(init);
1542
1543   init();
1544   $img = Imager->new();
1545   $img->open(file=>'image.ppm',type=>'pnm')
1546     || print "failed: ",$img->{ERRSTR},"\n";
1547   $scaled=$img->scale(xpixels=>400,ypixels=>400);
1548   $scaled->write(file=>'sc_image.ppm',type=>'pnm')
1549     || print "failed: ",$scaled->{ERRSTR},"\n";
1550
1551 =head1 DESCRIPTION
1552
1553 Imager is a module for creating and altering images - It is not meant
1554 as a replacement or a competitor to ImageMagick or GD. Both are
1555 excellent packages and well supported.
1556
1557 =head2 API
1558
1559 Almost all functions take the parameters in the hash fashion.
1560 Example:
1561
1562   $img->open(file=>'lena.png',type=>'png');
1563
1564 or just:
1565
1566   $img->open(file=>'lena.png');
1567
1568 =head2 Basic concept
1569
1570 An Image object is created with C<$img = Imager-E<gt>new()> Should
1571 this fail for some reason an explanation can be found in
1572 C<$Imager::ERRSTR> usually error messages are stored in
1573 C<$img-E<gt>{ERRSTR}>, but since no object is created this is the only
1574 way to give back errors.  C<$Imager::ERRSTR> is also used to report
1575 all errors not directly associated with an image object. Examples:
1576
1577   $img=Imager->new(); # This is an empty image (size is 0 by 0)
1578   $img->open(file=>'lena.png',type=>'png'); # initializes from file
1579
1580 or if you want to create an empty image:
1581
1582   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
1583
1584 This example creates a completely black image of width 400 and
1585 height 300 and 4 channels.
1586
1587 If you have an existing image, use img_set() to change it's dimensions
1588 - this will destroy any existing image data:
1589
1590   $img->img_set(xsize=>500, ysize=>500, channels=>4);
1591
1592 Color objects are created by calling the Imager::Color->new()
1593 method:
1594
1595   $color = Imager::Color->new($red, $green, $blue);
1596   $color = Imager::Color->new($red, $green, $blue, $alpha);
1597   $color = Imager::Color->new("#C0C0FF"); # html color specification
1598
1599 This object can then be passed to functions that require a color parameter.
1600
1601 Coordinates in Imager have the origin in the upper left corner.  The
1602 horizontal coordinate increases to the right and the vertical
1603 downwards.
1604
1605 =head2 Reading and writing images
1606
1607 C<$img-E<gt>read()> generally takes two parameters, 'file' and 'type'.
1608 If the type of the file can be determined from the suffix of the file
1609 it can be omitted.  Format dependant parameters are: For images of
1610 type 'raw' two extra parameters are needed 'xsize' and 'ysize', if the
1611 'channel' parameter is omitted for type 'raw' it is assumed to be 3.
1612 gif and png images might have a palette are converted to truecolor bit
1613 when read.  Alpha channel is preserved for png images irregardless of
1614 them being in RGB or gray colorspace.  Similarly grayscale jpegs are
1615 one channel images after reading them.  For jpeg images the iptc
1616 header information (stored in the APP13 header) is avaliable to some
1617 degree. You can get the raw header with C<$img-E<gt>{IPTCRAW}>, but
1618 you can also retrieve the most basic information with
1619 C<%hsh=$img-E<gt>parseiptc()> as always patches are welcome.  pnm has no
1620 extra options. Examples:
1621
1622   $img = Imager->new();
1623   $img->read(file=>"cover.jpg") or die $img->errstr; # gets type from name
1624
1625   $img = Imager->new();
1626   { local(*FH,$/); open(FH,"file.gif") or die $!; $a=<FH>; }
1627   $img->read(data=>$a,type=>'gif') or die $img->errstr;
1628
1629 The second example shows how to read an image from a scalar, this is
1630 usefull if your data originates from somewhere else than a filesystem
1631 such as a database over a DBI connection.
1632
1633 When writing to a tiff image file you can also specify the 'class'
1634 parameter, which can currently take a single value, "fax".  If class
1635 is set to fax then a tiff image which should be suitable for faxing
1636 will be written.  For the best results start with a grayscale image.
1637 By default the image is written at fine resolution you can override
1638 this by setting the "fax_fine" parameter to 0.
1639
1640 If you are reading from a gif image file, you can supply a 'colors'
1641 parameter which must be a reference to a scalar.  The referenced
1642 scalar will receive an array reference which contains the colors, each
1643 represented as an Imager::Color object.
1644
1645 If you already have an open file handle, for example a socket or a
1646 pipe, you can specify the 'fd' parameter instead of supplying a
1647 filename.  Please be aware that you need to use fileno() to retrieve
1648 the file descriptor for the file:
1649
1650   $img->read(fd=>fileno(FILE), type=>'gif') or die $img->errstr;
1651
1652 For writing using the 'fd' option you will probably want to set $| for
1653 that descriptor, since the writes to the file descriptor bypass Perl's
1654 (or the C libraries) buffering.  Setting $| should avoid out of order
1655 output.
1656
1657 *Note that load() is now an alias for read but will be removed later*
1658
1659 C<$img-E<gt>write> has the same interface as C<read()>.  The earlier
1660 comments on C<read()> for autodetecting filetypes apply.  For jpegs
1661 quality can be adjusted via the 'jpegquality' parameter (0-100).  The
1662 number of colorplanes in gifs are set with 'gifplanes' and should be
1663 between 1 (2 color) and 8 (256 colors).  It is also possible to choose
1664 between two quantizing methods with the parameter 'gifquant'. If set
1665 to mc it uses the mediancut algorithm from either giflibrary. If set
1666 to lm it uses a local means algorithm. It is then possible to give
1667 some extra settings. lmdither is the dither deviation amount in pixels
1668 (manhattan distance).  lmfixed can be an array ref who holds an array
1669 of Imager::Color objects.  Note that the local means algorithm needs
1670 much more cpu time but also gives considerable better results than the
1671 median cut algorithm.
1672
1673 Currently just for gif files, you can specify various options for the
1674 conversion from Imager's internal RGB format to the target's indexed
1675 file format.  If you set the gifquant option to 'gen', you can use the
1676 options specified under L<Quantization options>.
1677
1678 To see what Imager is compiled to support the following code snippet
1679 is sufficient:
1680
1681   use Imager;
1682   print "@{[keys %Imager::formats]}";
1683
1684 When reading raw images you need to supply the width and height of the
1685 image in the xsize and ysize options:
1686
1687   $img->read(file=>'foo.raw', xsize=>100, ysize=>100)
1688     or die "Cannot read raw image\n";
1689
1690 If your input file has more channels than you want, or (as is common),
1691 junk in the fourth channel, you can use the datachannels and
1692 storechannels options to control the number of channels in your input
1693 file and the resulting channels in your image.  For example, if your
1694 input image uses 32-bits per pixel with red, green, blue and junk
1695 values for each pixel you could do:
1696
1697   $img->read(file=>'foo.raw', xsize=>100, ysize=>100, datachannels=>4,
1698              storechannels=>3)
1699     or die "Cannot read raw image\n";
1700
1701 Normally the raw image is expected to have the value for channel 1
1702 immediately following channel 0 and channel 2 immediately following
1703 channel 1 for each pixel.  If your input image has all the channel 0
1704 values for the first line of the image, followed by all the channel 1
1705 values for the first line and so on, you can use the interleave option:
1706
1707   $img->read(file=>'foo.raw', xsize=100, ysize=>100, interleave=>1)
1708     or die "Cannot read raw image\n";
1709
1710 =head2 Multi-image files
1711
1712 Currently just for gif files, you can create files that contain more
1713 than one image.
1714
1715 To do this:
1716
1717   Imager->write_multi(\%opts, @images)
1718
1719 Where %opts describes 4 possible types of outputs:
1720
1721 =over 5
1722
1723 =item type
1724
1725 This is C<gif> for gif animations.
1726
1727 =item callback
1728
1729 A code reference which is called with a single parameter, the data to
1730 be written.  You can also specify $opts{maxbuffer} which is the
1731 maximum amount of data buffered.  Note that there can be larger writes
1732 than this if the file library writes larger blocks.  A smaller value
1733 maybe useful for writing to a socket for incremental display.
1734
1735 =item fd
1736
1737 The file descriptor to save the images to.
1738
1739 =item file
1740
1741 The name of the file to write to.
1742
1743 %opts may also include the keys from L<Gif options> and L<Quantization
1744 options>.
1745
1746 =back
1747
1748 You must also specify the file format using the 'type' option.
1749
1750 The current aim is to support other multiple image formats in the
1751 future, such as TIFF, and to support reading multiple images from a
1752 single file.
1753
1754 A simple example:
1755
1756     my @images;
1757     # ... code to put images in @images
1758     Imager->write_multi({type=>'gif',
1759                          file=>'anim.gif',
1760                          gif_delays=>[ (10) x @images ] },
1761                         @images)
1762     or die "Oh dear!";
1763
1764 =head2 Gif options
1765
1766 These options can be specified when calling write_multi() for gif
1767 files, when writing a single image with the gifquant option set to
1768 'gen', or for direct calls to i_writegif_gen and i_writegif_callback.
1769
1770 Note that some viewers will ignore some of these options
1771 (gif_user_input in particular).
1772
1773 =over 4
1774
1775 =item gif_each_palette
1776
1777 Each image in the gif file has it's own palette if this is non-zero.
1778 All but the first image has a local colour table (the first uses the
1779 global colour table.
1780
1781 =item interlace
1782
1783 The images are written interlaced if this is non-zero.
1784
1785 =item gif_delays
1786
1787 A reference to an array containing the delays between images, in 1/100
1788 seconds.
1789
1790 If you want the same delay for every frame you can simply set this to
1791 the delay in 1/100 seconds.
1792
1793 =item gif_user_input
1794
1795 A reference to an array contains user input flags.  If the given flag
1796 is non-zero the image viewer should wait for input before displaying
1797 the next image.
1798
1799 =item gif_disposal
1800
1801 A reference to an array of image disposal methods.  These define what
1802 should be done to the image before displaying the next one.  These are
1803 integers, where 0 means unspecified, 1 means the image should be left
1804 in place, 2 means restore to background colour and 3 means restore to
1805 the previous value.
1806
1807 =item gif_tran_color
1808
1809 A reference to an Imager::Color object, which is the colour to use for
1810 the palette entry used to represent transparency in the palette.  You
1811 need to set the transp option (see L<Quantization options>) for this
1812 value to be used.
1813
1814 =item gif_positions
1815
1816 A reference to an array of references to arrays which represent screen
1817 positions for each image.
1818
1819 =item gif_loop_count
1820
1821 If this is non-zero the Netscape loop extension block is generated,
1822 which makes the animation of the images repeat.
1823
1824 This is currently unimplemented due to some limitations in giflib.
1825
1826 =back
1827
1828 =head2 Quantization options
1829
1830 These options can be specified when calling write_multi() for gif
1831 files, when writing a single image with the gifquant option set to
1832 'gen', or for direct calls to i_writegif_gen and i_writegif_callback.
1833
1834 =over 4
1835
1836 =item colors
1837
1838 A arrayref of colors that are fixed.  Note that some color generators
1839 will ignore this.
1840
1841 =item transp
1842
1843 The type of transparency processing to perform for images with an
1844 alpha channel where the output format does not have a proper alpha
1845 channel (eg. gif).  This can be any of:
1846
1847 =over 4
1848
1849 =item none
1850
1851 No transparency processing is done. (default)
1852
1853 =item threshold
1854
1855 Pixels more transparent that tr_threshold are rendered as transparent.
1856
1857 =item errdiff
1858
1859 An error diffusion dither is done on the alpha channel.  Note that
1860 this is independent of the translation performed on the colour
1861 channels, so some combinations may cause undesired artifacts.
1862
1863 =item ordered
1864
1865 The ordered dither specified by tr_orddith is performed on the alpha
1866 channel.
1867
1868 =back
1869
1870 This will only be used if the image has an alpha channel, and if there
1871 is space in the palette for a transparency colour.
1872
1873 =item tr_threshold
1874
1875 The highest alpha value at which a pixel will be made transparent when
1876 transp is 'threshold'. (0-255, default 127)
1877
1878 =item tr_errdiff
1879
1880 The type of error diffusion to perform on the alpha channel when
1881 transp is 'errdiff'.  This can be any defined error diffusion type
1882 except for custom (see errdiff below).
1883
1884 =item tr_orddith
1885
1886 The type of ordered dither to perform on the alpha channel when transp
1887 is 'ordered'.  Possible values are:
1888
1889 =over 4
1890
1891 =item random
1892
1893 A semi-random map is used.  The map is the same each time.
1894
1895 =item dot8
1896
1897 8x8 dot dither.
1898
1899 =item dot4
1900
1901 4x4 dot dither
1902
1903 =item hline
1904
1905 horizontal line dither.
1906
1907 =item vline
1908
1909 vertical line dither.
1910
1911 =item "/line"
1912
1913 =item slashline
1914
1915 diagonal line dither
1916
1917 =item '\line'
1918
1919 =item backline
1920
1921 diagonal line dither
1922
1923 =item tiny
1924
1925 dot matrix dither (currently the default).  This is probably the best
1926 for displays (like web pages).
1927
1928 =item custom
1929
1930 A custom dither matrix is used - see tr_map
1931
1932 =back
1933
1934 =item tr_map
1935
1936 When tr_orddith is custom this defines an 8 x 8 matrix of integers
1937 representing the transparency threshold for pixels corresponding to
1938 each position.  This should be a 64 element array where the first 8
1939 entries correspond to the first row of the matrix.  Values should be
1940 betweern 0 and 255.
1941
1942 =item make_colors
1943
1944 Defines how the quantization engine will build the palette(s).
1945 Currently this is ignored if 'translate' is 'giflib', but that may
1946 change.  Possible values are:
1947
1948 =over 4
1949
1950 =item none
1951
1952 Only colors supplied in 'colors' are used.
1953
1954 =item webmap
1955
1956 The web color map is used (need url here.)
1957
1958 =item addi
1959
1960 The original code for generating the color map (Addi's code) is used.
1961
1962 =back
1963
1964 Other methods may be added in the future.
1965
1966 =item colors
1967
1968 A arrayref containing Imager::Color objects, which represents the
1969 starting set of colors to use in translating the images.  webmap will
1970 ignore this.  The final colors used are copied back into this array
1971 (which is expanded if necessary.)
1972
1973 =item max_colors
1974
1975 The maximum number of colors to use in the image.
1976
1977 =item translate
1978
1979 The method used to translate the RGB values in the source image into
1980 the colors selected by make_colors.  Note that make_colors is ignored
1981 whene translate is 'giflib'.
1982
1983 Possible values are:
1984
1985 =over 4
1986
1987 =item giflib
1988
1989 The giflib native quantization function is used.
1990
1991 =item closest
1992
1993 The closest color available is used.
1994
1995 =item perturb
1996
1997 The pixel color is modified by perturb, and the closest color is chosen.
1998
1999 =item errdiff
2000
2001 An error diffusion dither is performed.
2002
2003 =back
2004
2005 It's possible other transate values will be added.
2006
2007 =item errdiff
2008
2009 The type of error diffusion dither to perform.  These values (except
2010 for custom) can also be used in tr_errdif.
2011
2012 =over 4
2013
2014 =item floyd
2015
2016 Floyd-Steinberg dither
2017
2018 =item jarvis
2019
2020 Jarvis, Judice and Ninke dither
2021
2022 =item stucki
2023
2024 Stucki dither
2025
2026 =item custom
2027
2028 Custom.  If you use this you must also set errdiff_width,
2029 errdiff_height and errdiff_map.
2030
2031 =back
2032
2033 =item errdiff_width
2034
2035 =item errdiff_height
2036
2037 =item errdiff_orig
2038
2039 =item errdiff_map
2040
2041 When translate is 'errdiff' and errdiff is 'custom' these define a
2042 custom error diffusion map.  errdiff_width and errdiff_height define
2043 the size of the map in the arrayref in errdiff_map.  errdiff_orig is
2044 an integer which indicates the current pixel position in the top row
2045 of the map.
2046
2047 =item perturb
2048
2049 When translate is 'perturb' this is the magnitude of the random bias
2050 applied to each channel of the pixel before it is looked up in the
2051 color table.
2052
2053 =back
2054
2055 =head2 Obtaining/setting attributes of images
2056
2057 To get the size of an image in pixels the C<$img-E<gt>getwidth()> and
2058 C<$img-E<gt>getheight()> are used.
2059
2060 To get the number of channels in
2061 an image C<$img-E<gt>getchannels()> is used.  $img-E<gt>getmask() and
2062 $img-E<gt>setmask() are used to get/set the channel mask of the image.
2063
2064   $mask=$img->getmask();
2065   $img->setmask(mask=>1+2); # modify red and green only
2066   $img->setmask(mask=>8); # modify alpha only
2067   $img->setmask(mask=>$mask); # restore previous mask
2068
2069 The mask of an image describes which channels are updated when some
2070 operation is performed on an image.  Naturally it is not possible to
2071 apply masks to operations like scaling that alter the dimensions of
2072 images.
2073
2074 It is possible to have Imager find the number of colors in an image
2075 by using C<$img-E<gt>getcolorcount()>. It requires memory proportionally
2076 to the number of colors in the image so it is possible to have it
2077 stop sooner if you only need to know if there are more than a certain number
2078 of colors in the image.  If there are more colors than asked for
2079 the function return undef.  Examples:
2080
2081   if (!defined($img->getcolorcount(maxcolors=>512)) {
2082     print "Less than 512 colors in image\n";
2083   }
2084
2085 =head2 Drawing Methods
2086
2087 IMPLEMENTATION MORE OR LESS DONE CHECK THE TESTS
2088 DOCUMENTATION OF THIS SECTION OUT OF SYNC
2089
2090 It is possible to draw with graphics primitives onto images.  Such
2091 primitives include boxes, arcs, circles and lines.  A reference
2092 oriented list follows.
2093
2094 Box:
2095   $img->box(color=>$blue,xmin=>10,ymin=>30,xmax=>200,ymax=>300,filled=>1);
2096
2097 The above example calls the C<box> method for the image and the box
2098 covers the pixels with in the rectangle specified.  If C<filled> is
2099 ommited it is drawn as an outline.  If any of the edges of the box are
2100 ommited it will snap to the outer edge of the image in that direction.
2101 Also if a color is omitted a color with (255,255,255,255) is used
2102 instead.
2103
2104 Arc:
2105   $img->arc(color=>$red, r=20, x=>200, y=>100, d1=>10, d2=>20 );
2106
2107 This creates a filled red arc with a 'center' at (200, 100) and spans
2108 10 degrees and the slice has a radius of 20. SEE section on BUGS.
2109
2110 Circle:
2111   $img->circle(color=>$green, r=50, x=>200, y=>100);
2112
2113 This creates a green circle with its center at (200, 100) and has a
2114 radius of 20.
2115
2116 Line:
2117   $img->line(color=>$green, x1=10, x2=>100,
2118                             y1=>20, y2=>50, antialias=>1 );
2119
2120 That draws an antialiased line from (10,100) to (20,50).
2121
2122 Polyline:
2123   $img->polyline(points=>[[$x0,$y0],[$x1,$y1],[$x2,$y2]],color=>$red);
2124   $img->polyline(x=>[$x0,$x1,$x2], y=>[$y0,$y1,$y2], antialias=>1);
2125
2126 Polyline is used to draw multilple lines between a series of points.
2127 The point set can either be specified as an arrayref to an array of
2128 array references (where each such array represents a point).  The
2129 other way is to specify two array references.
2130
2131 =head2 Text rendering
2132
2133 Text rendering is described in the Imager::Font manpage.
2134
2135 =head2 Image resizing
2136
2137 To scale an image so porportions are maintained use the
2138 C<$img-E<gt>scale()> method.  if you give either a xpixels or ypixels
2139 parameter they will determine the width or height respectively.  If
2140 both are given the one resulting in a larger image is used.  example:
2141 C<$img> is 700 pixels wide and 500 pixels tall.
2142
2143   $img->scale(xpixels=>400); # 400x285
2144   $img->scale(ypixels=>400); # 560x400
2145
2146   $img->scale(xpixels=>400,ypixels=>400); # 560x400
2147   $img->scale(xpixels=>400,ypixels=>400,type=>min); # 400x285
2148
2149   $img->scale(scalefactor=>0.25); 175x125 $img->scale(); # 350x250
2150
2151 if you want to create low quality previews of images you can pass
2152 C<qtype=E<gt>'preview'> to scale and it will use nearest neighbor
2153 sampling instead of filtering. It is much faster but also generates
2154 worse looking images - especially if the original has a lot of sharp
2155 variations and the scaled image is by more than 3-5 times smaller than
2156 the original.
2157
2158 If you need to scale images per axis it is best to do it simply by
2159 calling scaleX and scaleY.  You can pass either 'scalefactor' or
2160 'pixels' to both functions.
2161
2162 Another way to resize an image size is to crop it.  The parameters
2163 to crop are the edges of the area that you want in the returned image.
2164 If a parameter is omited a default is used instead.
2165
2166   $newimg = $img->crop(left=>50, right=>100, top=>10, bottom=>100);
2167   $newimg = $img->crop(left=>50, top=>10, width=>50, height=>90);
2168   $newimg = $img->crop(left=>50, right=>100); # top
2169
2170 You can also specify width and height parameters which will produce a
2171 new image cropped from the center of the input image, with the given
2172 width and height.
2173
2174   $newimg = $img->crop(width=>50, height=>50);
2175
2176 The width and height parameters take precedence over the left/right
2177 and top/bottom parameters respectively.
2178
2179 =head2 Copying images
2180
2181 To create a copy of an image use the C<copy()> method.  This is usefull
2182 if you want to keep an original after doing something that changes the image
2183 inplace like writing text.
2184
2185   $img=$orig->copy();
2186
2187 To copy an image to onto another image use the C<paste()> method.
2188
2189   $dest->paste(left=>40,top=>20,img=>$logo);
2190
2191 That copies the entire C<$logo> image onto the C<$dest> image so that the
2192 upper left corner of the C<$logo> image is at (40,20).
2193
2194
2195 =head2 Flipping images
2196
2197 An inplace horizontal or vertical flip is possible by calling the
2198 C<flip()> method.  If the original is to be preserved it's possible to
2199 make a copy first.  The only parameter it takes is the C<dir>
2200 parameter which can take the values C<h>, C<v>, C<vh> and C<hv>.
2201
2202   $img->flip(dir=>"h");       # horizontal flip
2203   $img->flip(dir=>"vh");      # vertical and horizontal flip
2204   $nimg = $img->copy->flip(dir=>"v"); # make a copy and flip it vertically
2205
2206 =head2 Blending Images
2207
2208 To put an image or a part of an image directly
2209 into another it is best to call the C<paste()> method on the image you
2210 want to add to.
2211
2212   $img->paste(img=>$srcimage,left=>30,top=>50);
2213
2214 That will take paste C<$srcimage> into C<$img> with the upper
2215 left corner at (30,50).  If no values are given for C<left>
2216 or C<top> they will default to 0.
2217
2218 A more complicated way of blending images is where one image is
2219 put 'over' the other with a certain amount of opaqueness.  The
2220 method that does this is rubthrough.
2221
2222   $img->rubthrough(src=>$srcimage,tx=>30,ty=>50);
2223
2224 That will take the image C<$srcimage> and overlay it with the
2225 upper left corner at (30,50).  The C<$srcimage> must be a 4 channel
2226 image.  The last channel is used as an alpha channel.
2227
2228
2229 =head2 Filters
2230
2231 A special image method is the filter method. An example is:
2232
2233   $img->filter(type=>'autolevels');
2234
2235 This will call the autolevels filter.  Here is a list of the filters
2236 that are always avaliable in Imager.  This list can be obtained by
2237 running the C<filterlist.perl> script that comes with the module
2238 source.
2239
2240   Filter          Arguments
2241   turbnoise
2242   autolevels      lsat(0.1) usat(0.1) skew(0)
2243   radnoise
2244   noise           amount(3) subtype(0)
2245   contrast        intensity
2246   hardinvert
2247   gradgen         xo yo colors dist
2248
2249 The default values are in parenthesis.  All parameters must have some
2250 value but if a parameter has a default value it may be omitted when
2251 calling the filter function.
2252
2253 FIXME: make a seperate pod for filters?
2254
2255 =head2 Color transformations
2256
2257 You can use the convert method to transform the color space of an
2258 image using a matrix.  For ease of use some presets are provided.
2259
2260 The convert method can be used to:
2261
2262 =over 4
2263
2264 =item *
2265
2266 convert an RGB or RGBA image to grayscale.
2267
2268 =item *
2269
2270 convert a grayscale image to RGB.
2271
2272 =item *
2273
2274 extract a single channel from an image.
2275
2276 =item *
2277
2278 set a given channel to a particular value (or from another channel)
2279
2280 =back
2281
2282 The currently defined presets are:
2283
2284 =over
2285
2286 =item gray
2287
2288 =item grey
2289
2290 converts an RGBA image into a grayscale image with alpha channel, or
2291 an RGB image into a grayscale image without an alpha channel.
2292
2293 This weights the RGB channels at 22.2%, 70.7% and 7.1% respectively.
2294
2295 =item noalpha
2296
2297 removes the alpha channel from a 2 or 4 channel image.  An identity
2298 for other images.
2299
2300 =item red
2301
2302 =item channel0
2303
2304 extracts the first channel of the image into a single channel image
2305
2306 =item green
2307
2308 =item channel1
2309
2310 extracts the second channel of the image into a single channel image
2311
2312 =item blue
2313
2314 =item channel2
2315
2316 extracts the third channel of the image into a single channel image
2317
2318 =item alpha
2319
2320 extracts the alpha channel of the image into a single channel image.
2321
2322 If the image has 1 or 3 channels (assumed to be grayscale of RGB) then
2323 the resulting image will be all white.
2324
2325 =item rgb
2326
2327 converts a grayscale image to RGB, preserving the alpha channel if any
2328
2329 =item addalpha
2330
2331 adds an alpha channel to a grayscale or RGB image.  Preserves an
2332 existing alpha channel for a 2 or 4 channel image.
2333
2334 =back
2335
2336 For example, to convert an RGB image into a greyscale image:
2337
2338   $new = $img->convert(preset=>'grey'); # or gray
2339
2340 or to convert a grayscale image to an RGB image:
2341
2342   $new = $img->convert(preset=>'rgb');
2343
2344 The presets aren't necessary simple constants in the code, some are
2345 generated based on the number of channels in the input image.
2346
2347 If you want to perform some other colour transformation, you can use
2348 the 'matrix' parameter.
2349
2350 For each output pixel the following matrix multiplication is done:
2351
2352      channel[0]       [ [ $c00, $c01, ...  ]        inchannel[0]
2353    [     ...      ] =          ...              x [     ...        ]
2354      channel[n-1]       [ $cn0, ...,  $cnn ] ]      inchannel[max]
2355                                                           1
2356
2357 So if you want to swap the red and green channels on a 3 channel image:
2358
2359   $new = $img->convert(matrix=>[ [ 0, 1, 0 ],
2360                                  [ 1, 0, 0 ],
2361                                  [ 0, 0, 1 ] ]);
2362
2363 or to convert a 3 channel image to greyscale using equal weightings:
2364
2365   $new = $img->convert(matrix=>[ [ 0.333, 0.333, 0.334 ] ])
2366
2367 =head2 Color Mappings
2368
2369 You can use the map method to map the values of each channel of an
2370 image independently using a list of lookup tables.  It's important to
2371 realize that the modification is made inplace.  The function simply
2372 returns the input image again or undef on failure.
2373
2374 Each channel is mapped independently through a lookup table with 256
2375 entries.  The elements in the table should not be less than 0 and not
2376 greater than 255.  If they are out of the 0..255 range they are
2377 clamped to the range.  If a table does not contain 256 entries it is
2378 silently ignored.
2379
2380 Single channels can mapped by specifying their name and the mapping
2381 table.  The channel names are C<red>, C<green>, C<blue>, C<alpha>.
2382
2383   @map = map { int( $_/2 } 0..255;
2384   $img->map( red=>\@map );
2385
2386 It is also possible to specify a single map that is applied to all
2387 channels, alpha channel included.  For example this applies a gamma
2388 correction with a gamma of 1.4 to the input image.
2389
2390   $gamma = 1.4;
2391   @map = map { int( 0.5 + 255*($_/255)**$gamma ) } 0..255;
2392   $img->map(all=> \@map);
2393
2394 The C<all> map is used as a default channel, if no other map is
2395 specified for a channel then the C<all> map is used instead.  If we
2396 had not wanted to apply gamma to the alpha channel we would have used:
2397
2398   $img->map(all=> \@map, alpha=>[]);
2399
2400 Since C<[]> contains fewer than 256 element the gamma channel is
2401 unaffected.
2402
2403 It is also possible to simply specify an array of maps that are
2404 applied to the images in the rgba order.  For example to apply
2405 maps to the C<red> and C<blue> channels one would use:
2406
2407   $img->map(maps=>[\@redmap, [], \@bluemap]);
2408
2409
2410
2411 =head2 Transformations
2412
2413 Another special image method is transform.  It can be used to generate
2414 warps and rotations and such features.  It can be given the operations
2415 in postfix notation or the module Affix::Infix2Postfix can be used.
2416 Look in the test case t/t55trans.t for an example.
2417
2418 transform() needs expressions (or opcodes) that determine the source
2419 pixel for each target pixel.  Source expressions are infix expressions
2420 using any of the +, -, *, / or ** binary operators, the - unary
2421 operator, ( and ) for grouping and the sin() and cos() functions.  The
2422 target pixel is input as the variables x and y.
2423
2424 You specify the x and y expressions as xexpr and yexpr respectively.
2425 You can also specify opcodes directly, but that's magic deep enough
2426 that you can look at the source code.
2427
2428 You can still use the transform() function, but the transform2()
2429 function is just as fast and is more likely to be enhanced and
2430 maintained.
2431
2432 Later versions of Imager also support a transform2() class method
2433 which allows you perform a more general set of operations, rather than
2434 just specifying a spatial transformation as with the transform()
2435 method, you can also perform colour transformations, image synthesis
2436 and image combinations.
2437
2438 transform2() takes an reference to an options hash, and a list of
2439 images to operate one (this list may be empty):
2440
2441   my %opts;
2442   my @imgs;
2443   ...
2444   my $img = Imager::transform2(\%opts, @imgs)
2445       or die "transform2 failed: $Imager::ERRSTR";
2446
2447 The options hash may define a transformation function, and optionally:
2448
2449 =over 4
2450
2451 =item *
2452
2453 width - the width of the image in pixels.  If this isn't supplied the
2454 width of the first input image is used.  If there are no input images
2455 an error occurs.
2456
2457 =item *
2458
2459 height - the height of the image in pixels.  If this isn't supplied
2460 the height of the first input image is used.  If there are no input
2461 images an error occurs.
2462
2463 =item *
2464
2465 constants - a reference to hash of constants to define for the
2466 expression engine.  Some extra constants are defined by Imager
2467
2468 =back
2469
2470 The tranformation function is specified using either the expr or
2471 rpnexpr member of the options.
2472
2473 =over 4
2474
2475 =item Infix expressions
2476
2477 You can supply infix expressions to transform 2 with the expr keyword.
2478
2479 $opts{expr} = 'return getp1(w-x, h-y)'
2480
2481 The 'expression' supplied follows this general grammar:
2482
2483    ( identifier '=' expr ';' )* 'return' expr
2484
2485 This allows you to simplify your expressions using variables.
2486
2487 A more complex example might be:
2488
2489 $opts{expr} = 'pix = getp1(x,y); return if(value(pix)>0.8,pix*0.8,pix)'
2490
2491 Currently to use infix expressions you must have the Parse::RecDescent
2492 module installed (available from CPAN).  There is also what might be a
2493 significant delay the first time you run the infix expression parser
2494 due to the compilation of the expression grammar.
2495
2496 =item Postfix expressions
2497
2498 You can supply postfix or reverse-polish notation expressions to
2499 transform2() through the rpnexpr keyword.
2500
2501 The parser for rpnexpr emulates a stack machine, so operators will
2502 expect to see their parameters on top of the stack.  A stack machine
2503 isn't actually used during the image transformation itself.
2504
2505 You can store the value at the top of the stack in a variable called
2506 foo using !foo and retrieve that value again using @foo.  The !foo
2507 notation will pop the value from the stack.
2508
2509 An example equivalent to the infix expression above:
2510
2511  $opts{rpnexpr} = 'x y getp1 !pix @pix value 0.8 gt @pix 0.8 * @pix ifp'
2512
2513 =back
2514
2515 transform2() has a fairly rich range of operators.
2516
2517 =over 4
2518
2519 =item +, *, -, /, %, **
2520
2521 multiplication, addition, subtraction, division, remainder and
2522 exponentiation.  Multiplication, addition and subtraction can be used
2523 on colour values too - though you need to be careful - adding 2 white
2524 values together and multiplying by 0.5 will give you grey, not white.
2525
2526 Division by zero (or a small number) just results in a large number.
2527 Modulo zero (or a small number) results in zero.
2528
2529 =item sin(N), cos(N), atan2(y,x)
2530
2531 Some basic trig functions.  They work in radians, so you can't just
2532 use the hue values.
2533
2534 =item distance(x1, y1, x2, y2)
2535
2536 Find the distance between two points.  This is handy (along with
2537 atan2()) for producing circular effects.
2538
2539 =item sqrt(n)
2540
2541 Find the square root.  I haven't had much use for this since adding
2542 the distance() function.
2543
2544 =item abs(n)
2545
2546 Find the absolute value.
2547
2548 =item getp1(x,y), getp2(x,y), getp3(x, y)
2549
2550 Get the pixel at position (x,y) from the first, second or third image
2551 respectively.  I may add a getpn() function at some point, but this
2552 prevents static checking of the instructions against the number of
2553 images actually passed in.
2554
2555 =item value(c), hue(c), sat(c), hsv(h,s,v)
2556
2557 Separates a colour value into it's value (brightness), hue (colour)
2558 and saturation elements.  Use hsv() to put them back together (after
2559 suitable manipulation).
2560
2561 =item red(c), green(c), blue(c), rgb(r,g,b)
2562
2563 Separates a colour value into it's red, green and blue colours.  Use
2564 rgb(r,g,b) to put it back together.
2565
2566 =item int(n)
2567
2568 Convert a value to an integer.  Uses a C int cast, so it may break on
2569 large values.
2570
2571 =item if(cond,ntrue,nfalse), if(cond,ctrue,cfalse)
2572
2573 A simple (and inefficient) if function.
2574
2575 =item <=,<,==,>=,>,!=
2576
2577 Relational operators (typically used with if()).  Since we're working
2578 with floating point values the equalities are 'near equalities' - an
2579 epsilon value is used.
2580
2581 =item &&, ||, not(n)
2582
2583 Basic logical operators.
2584
2585 =back
2586
2587 A few examples:
2588
2589 =over 4
2590
2591 =item rpnexpr=>'x 25 % 15 * y 35 % 10 * getp1 !pat x y getp1 !pix @pix sat 0.7 gt @pat @pix ifp'
2592
2593 tiles a smaller version of the input image over itself where the
2594 colour has a saturation over 0.7.
2595
2596 =item rpnexpr=>'x 25 % 15 * y 35 % 10 * getp1 !pat y 360 / !rat x y getp1 1 @rat - pmult @pat @rat pmult padd'
2597
2598 tiles the input image over itself so that at the top of the image the
2599 full-size image is at full strength and at the bottom the tiling is
2600 most visible.
2601
2602 =item rpnexpr=>'x y getp1 !pix @pix value 0.96 gt @pix sat 0.1 lt and 128 128 255 rgb @pix ifp'
2603
2604 replace pixels that are white or almost white with a palish blue
2605
2606 =item rpnexpr=>'x 35 % 10 * y 45 % 8 * getp1 !pat x y getp1 !pix @pix sat 0.2 lt @pix value 0.9 gt and @pix @pat @pix value 2 / 0.5 + pmult ifp'
2607
2608 Tiles the input image overitself where the image isn't white or almost
2609 white.
2610
2611 =item rpnexpr=>'x y 160 180 distance !d y 180 - x 160 - atan2 !a @d 10 / @a + 3.1416 2 * % !a2 @a2 180 * 3.1416 / 1 @a2 sin 1 + 2 / hsv'
2612
2613 Produces a spiral.
2614
2615 =item rpnexpr=>'x y 160 180 distance !d y 180 - x 160 - atan2 !a @d 10 / @a + 3.1416 2 * % !a2 @a 180 * 3.1416 / 1 @a2 sin 1 + 2 / hsv'
2616
2617 A spiral built on top of a colour wheel.
2618
2619 =back
2620
2621 For details on expression parsing see L<Imager::Expr>.  For details on
2622 the virtual machine used to transform the images, see
2623 L<Imager::regmach.pod>.
2624
2625 =head2 Plugins
2626
2627 It is possible to add filters to the module without recompiling the
2628 module itself.  This is done by using DSOs (Dynamic shared object)
2629 avaliable on most systems.  This way you can maintain our own filters
2630 and not have to get me to add it, or worse patch every new version of
2631 the Module.  Modules can be loaded AND UNLOADED at runtime.  This
2632 means that you can have a server/daemon thingy that can do something
2633 like:
2634
2635   load_plugin("dynfilt/dyntest.so")  || die "unable to load plugin\n";
2636   %hsh=(a=>35,b=>200,type=>lin_stretch);
2637   $img->filter(%hsh);
2638   unload_plugin("dynfilt/dyntest.so") || die "unable to load plugin\n";
2639   $img->write(type=>'pnm',file=>'testout/t60.jpg')
2640     || die "error in write()\n";
2641
2642 Someone decides that the filter is not working as it should -
2643 dyntest.c modified and recompiled.
2644
2645   load_plugin("dynfilt/dyntest.so") || die "unable to load plugin\n";
2646   $img->filter(%hsh);
2647
2648 An example plugin comes with the module - Please send feedback to
2649 addi@umich.edu if you test this.
2650
2651 Note: This seems to test ok on the following systems:
2652 Linux, Solaris, HPUX, OpenBSD, FreeBSD, TRU64/OSF1, AIX.
2653 If you test this on other systems please let me know.
2654
2655 =head1 BUGS
2656
2657 box, arc, circle do not support antialiasing yet.  arc, is only filled
2658 as of yet.  Some routines do not return $self where they should.  This
2659 affects code like this, C<$img-E<gt>box()-E<gt>arc()> where an object
2660 is expected.
2661
2662 When saving Gif images the program does NOT try to shave of extra
2663 colors if it is possible.  If you specify 128 colors and there are
2664 only 2 colors used - it will have a 128 colortable anyway.
2665
2666 =head1 AUTHOR
2667
2668 Arnar M. Hrafnkelsson, addi@umich.edu, and recently lots of assistance
2669 from Tony Cook.  See the README for a complete list.
2670
2671 =head1 SEE ALSO
2672
2673 perl(1), Imager::Color(3), Imager::Font, Affix::Infix2Postfix(3),
2674 Parse::RecDescent(3) http://www.eecs.umich.edu/~addi/perl/Imager/
2675
2676 =cut