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