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