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