Imager.pm

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