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