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