Imager.pm

   1 package Imager;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS);
   5 use IO::File;
   6
   7 use Imager::Color;
   8 use Imager::Font;
   9
  10 @EXPORT_OK = qw(
  11                 init
  12                 init_log
  13                 DSO_open
  14                 DSO_close
  15                 DSO_funclist
  16                 DSO_call
  17
  18                 load_plugin
  19                 unload_plugin
  20
  21                 i_list_formats
  22                 i_has_format
  23
  24                 i_color_new
  25                 i_color_set
  26                 i_color_info
  27
  28                 i_img_empty
  29                 i_img_empty_ch
  30                 i_img_exorcise
  31                 i_img_destroy
  32
  33                 i_img_info
  34
  35                 i_img_setmask
  36                 i_img_getmask
  37
  38                 i_draw
  39                 i_line_aa
  40                 i_box
  41                 i_box_filled
  42                 i_arc
  43                 i_circle_aa
  44
  45                 i_bezier_multi
  46                 i_poly_aa
  47                 i_poly_aa_cfill
  48
  49                 i_copyto
  50                 i_rubthru
  51                 i_scaleaxis
  52                 i_scale_nn
  53                 i_haar
  54                 i_count_colors
  55
  56                 i_gaussian
  57                 i_conv
  58
  59                 i_convert
  60                 i_map
  61
  62                 i_img_diff
  63
  64                 i_init_fonts
  65                 i_t1_new
  66                 i_t1_destroy
  67                 i_t1_set_aa
  68                 i_t1_cp
  69                 i_t1_text
  70                 i_t1_bbox
  71
  72                 i_tt_set_aa
  73                 i_tt_cp
  74                 i_tt_text
  75                 i_tt_bbox
  76
  77                 i_readjpeg_wiol
  78                 i_writejpeg_wiol
  79
  80                 i_readtiff_wiol
  81                 i_writetiff_wiol
  82                 i_writetiff_wiol_faxable
  83
  84                 i_readpng_wiol
  85                 i_writepng_wiol
  86
  87                 i_readgif
  88                 i_readgif_wiol
  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_wiol
  97
  98                 i_readraw_wiol
  99                 i_writeraw_wiol
 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 @EXPORT=qw(
 123            init_log
 124            i_list_formats
 125            i_has_format
 126            malloc_state
 127            i_color_new
 128
 129            i_img_empty
 130            i_img_empty_ch
 131           );
 132
 133 %EXPORT_TAGS=
 134   (handy => [qw(
 135                 newfont
 136                 newcolor
 137                 NF
 138                 NC
 139                )],
 140    all => [@EXPORT_OK],
 141    default => [qw(
 142                   load_plugin
 143                   unload_plugin
 144                  )]);
 145
 146 BEGIN {
 147   require Exporter;
 148   require DynaLoader;
 149
 150   $VERSION = '0.39';
 151   @ISA = qw(Exporter DynaLoader);
 152   bootstrap Imager $VERSION;
 153 }
 154
 155 BEGIN {
 156   i_init_fonts(); # Initialize font engines
 157   Imager::Font::__init();
 158   for(i_list_formats()) { $formats{$_}++; }
 159
 160   if ($formats{'t1'}) {
 161     i_t1_set_aa(1);
 162   }
 163
 164   if (!$formats{'t1'} and !$formats{'tt'}
 165       && !$formats{'ft2'} && !$formats{'w32'}) {
 166     $fontstate='no font support';
 167   }
 168
 169   %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
 170
 171   $DEBUG=0;
 172
 173   # the members of the subhashes under %filters are:
 174   #  callseq - a list of the parameters to the underlying filter in the
 175   #            order they are passed
 176   #  callsub - a code ref that takes a named parameter list and calls the
 177   #            underlying filter
 178   #  defaults - a hash of default values
 179   #  names - defines names for value of given parameters so if the names
 180   #          field is foo=> { bar=>1 }, and the user supplies "bar" as the
 181   #          foo parameter, the filter will receive 1 for the foo
 182   #          parameter
 183   $filters{contrast}={
 184                       callseq => ['image','intensity'],
 185                       callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
 186                      };
 187
 188   $filters{noise} ={
 189                     callseq => ['image', 'amount', 'subtype'],
 190                     defaults => { amount=>3,subtype=>0 },
 191                     callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
 192                    };
 193
 194   $filters{hardinvert} ={
 195                          callseq => ['image'],
 196                          defaults => { },
 197                          callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
 198                         };
 199
 200   $filters{autolevels} ={
 201                          callseq => ['image','lsat','usat','skew'],
 202                          defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
 203                          callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
 204                         };
 205
 206   $filters{turbnoise} ={
 207                         callseq => ['image'],
 208                         defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
 209                         callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
 210                        };
 211
 212   $filters{radnoise} ={
 213                        callseq => ['image'],
 214                        defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
 215                        callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
 216                       };
 217
 218   $filters{conv} ={
 219                        callseq => ['image', 'coef'],
 220                        defaults => { },
 221                        callsub => sub { my %hsh=@_; i_conv($hsh{image},$hsh{coef}); }
 222                       };
 223
 224   $filters{gradgen} ={
 225                        callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 226                        defaults => { },
 227                        callsub => sub { my %hsh=@_; i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, $hsh{colors}, $hsh{dist}); }
 228                       };
 229
 230   $filters{nearest_color} ={
 231                             callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 232                             defaults => { },
 233                             callsub => sub { my %hsh=@_; i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, $hsh{colors}, $hsh{dist}); }
 234                            };
 235   $filters{gaussian} = {
 236                         callseq => [ 'image', 'stddev' ],
 237                         defaults => { },
 238                         callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
 239                        };
 240   $filters{mosaic} =
 241     {
 242      callseq => [ qw(image size) ],
 243      defaults => { size => 20 },
 244      callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
 245     };
 246   $filters{bumpmap} =
 247     {
 248      callseq => [ qw(image bump elevation lightx lighty st) ],
 249      defaults => { elevation=>0, st=> 2 },
 250      callsub => sub {
 251        my %hsh = @_;
 252        i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
 253                  $hsh{lightx}, $hsh{lighty}, $hsh{st});
 254      },
 255     };
 256   $filters{bumpmap_complex} =
 257     {
 258      callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
 259      defaults => {
 260                   channel => 0,
 261                   tx => 0,
 262                   ty => 0,
 263                   Lx => 0.2,
 264                   Ly => 0.4,
 265                   Lz => -1.0,
 266                   cd => 1.0,
 267                   cs => 40,
 268                   n => 1.3,
 269                   Ia => Imager::Color->new(rgb=>[0,0,0]),
 270                   Il => Imager::Color->new(rgb=>[255,255,255]),
 271                   Is => Imager::Color->new(rgb=>[255,255,255]),
 272                  },
 273      callsub => sub {
 274        my %hsh = @_;
 275        i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
 276                  $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
 277                  $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
 278                  $hsh{Is});
 279      },
 280     };
 281   $filters{postlevels} =
 282     {
 283      callseq  => [ qw(image levels) ],
 284      defaults => { levels => 10 },
 285      callsub  => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
 286     };
 287   $filters{watermark} =
 288     {
 289      callseq  => [ qw(image wmark tx ty pixdiff) ],
 290      defaults => { pixdiff=>10, tx=>0, ty=>0 },
 291      callsub  =>
 292      sub {
 293        my %hsh = @_;
 294        i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
 295                    $hsh{pixdiff});
 296      },
 297     };
 298   $filters{fountain} =
 299     {
 300      callseq  => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
 301      names    => {
 302                   ftype => { linear         => 0,
 303                              bilinear       => 1,
 304                              radial         => 2,
 305                              radial_square  => 3,
 306                              revolution     => 4,
 307                              conical        => 5 },
 308                   repeat => { none      => 0,
 309                               sawtooth  => 1,
 310                               triangle  => 2,
 311                               saw_both  => 3,
 312                               tri_both  => 4,
 313                             },
 314                   super_sample => {
 315                                    none    => 0,
 316                                    grid    => 1,
 317                                    random  => 2,
 318                                    circle  => 3,
 319                                   },
 320                   combine => {
 321                               none      => 0,
 322                               normal    => 1,
 323                               multiply  => 2, mult => 2,
 324                               dissolve  => 3,
 325                               add       => 4,
 326                               subtract  => 5, 'sub' => 5,
 327                               diff      => 6,
 328                               lighten   => 7,
 329                               darken    => 8,
 330                               hue       => 9,
 331                               sat       => 10,
 332                               value     => 11,
 333                               color     => 12,
 334                              },
 335                  },
 336      defaults => { ftype => 0, repeat => 0, combine => 0,
 337                    super_sample => 0, ssample_param => 4,
 338                    segments=>[
 339                               [ 0, 0.5, 1,
 340                                 Imager::Color->new(0,0,0),
 341                                 Imager::Color->new(255, 255, 255),
 342                                 0, 0,
 343                               ],
 344                              ],
 345                  },
 346      callsub  =>
 347      sub {
 348        my %hsh = @_;
 349        i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
 350                   $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
 351                   $hsh{ssample_param}, $hsh{segments});
 352      },
 353     };
 354   $filters{unsharpmask} =
 355     {
 356      callseq => [ qw(image stddev scale) ],
 357      defaults => { stddev=>2.0, scale=>1.0 },
 358      callsub =>
 359      sub {
 360        my %hsh = @_;
 361        i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
 362      },
 363     };
 364
 365   $FORMATGUESS=\&def_guess_type;
 366 }
 367
 368 #
 369 # Non methods
 370 #
 371
 372 # initlize Imager
 373 # NOTE: this might be moved to an import override later on
 374
 375 #sub import {
 376 #  my $pack = shift;
 377 #  (look through @_ for special tags, process, and remove them);
 378 #  use Data::Dumper;
 379 #  print Dumper($pack);
 380 #  print Dumper(@_);
 381 #}
 382
 383 sub init {
 384   my %parms=(loglevel=>1,@_);
 385   if ($parms{'log'}) {
 386     init_log($parms{'log'},$parms{'loglevel'});
 387   }
 388
 389 #    if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
 390 #    if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
 391 #       i_init_fonts();
 392 #       $fontstate='ok';
 393 #    }
 394 }
 395
 396 END {
 397   if ($DEBUG) {
 398     print "shutdown code\n";
 399     #   for(keys %instances) { $instances{$_}->DESTROY(); }
 400     malloc_state(); # how do decide if this should be used? -- store something from the import
 401     print "Imager exiting\n";
 402   }
 403 }
 404
 405 # Load a filter plugin
 406
 407 sub load_plugin {
 408   my ($filename)=@_;
 409   my $i;
 410   my ($DSO_handle,$str)=DSO_open($filename);
 411   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
 412   my %funcs=DSO_funclist($DSO_handle);
 413   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
 414   $i=0;
 415   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
 416
 417   $DSOs{$filename}=[$DSO_handle,\%funcs];
 418
 419   for(keys %funcs) {
 420     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
 421     $DEBUG && print "eval string:\n",$evstr,"\n";
 422     eval $evstr;
 423     print $@ if $@;
 424   }
 425   return 1;
 426 }
 427
 428 # Unload a plugin
 429
 430 sub unload_plugin {
 431   my ($filename)=@_;
 432
 433   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
 434   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
 435   for(keys %{$funcref}) {
 436     delete $filters{$_};
 437     $DEBUG && print "unloading: $_\n";
 438   }
 439   my $rc=DSO_close($DSO_handle);
 440   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
 441   return 1;
 442 }
 443
 444 # take the results of i_error() and make a message out of it
 445 sub _error_as_msg {
 446   return join(": ", map $_->[0], i_errors());
 447 }
 448
 449 # this function tries to DWIM for color parameters
 450 #  color objects are used as is
 451 #  simple scalars are simply treated as single parameters to Imager::Color->new
 452 #  hashrefs are treated as named argument lists to Imager::Color->new
 453 #  arrayrefs are treated as list arguments to Imager::Color->new iff any
 454 #    parameter is > 1
 455 #  other arrayrefs are treated as list arguments to Imager::Color::Float
 456
 457 sub _color {
 458   my $arg = shift;
 459   my $result;
 460
 461   if (ref $arg) {
 462     if (UNIVERSAL::isa($arg, "Imager::Color")
 463         || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
 464       $result = $arg;
 465     }
 466     else {
 467       if ($arg =~ /^HASH\(/) {
 468         $result = Imager::Color->new(%$arg);
 469       }
 470       elsif ($arg =~ /^ARRAY\(/) {
 471         if (grep $_ > 1, @$arg) {
 472           $result = Imager::Color->new(@$arg);
 473         }
 474         else {
 475           $result = Imager::Color::Float->new(@$arg);
 476         }
 477       }
 478       else {
 479         $Imager::ERRSTR = "Not a color";
 480       }
 481     }
 482   }
 483   else {
 484     # assume Imager::Color::new knows how to handle it
 485     $result = Imager::Color->new($arg);
 486   }
 487
 488   return $result;
 489 }
 490
 491
 492 #
 493 # Methods to be called on objects.
 494 #
 495
 496 # Create a new Imager object takes very few parameters.
 497 # usually you call this method and then call open from
 498 # the resulting object
 499
 500 sub new {
 501   my $class = shift;
 502   my $self ={};
 503   my %hsh=@_;
 504   bless $self,$class;
 505   $self->{IMG}=undef;    # Just to indicate what exists
 506   $self->{ERRSTR}=undef; #
 507   $self->{DEBUG}=$DEBUG;
 508   $self->{DEBUG} && print "Initialized Imager\n";
 509   if ($hsh{xsize} && $hsh{ysize}) { $self->img_set(%hsh); }
 510   return $self;
 511 }
 512
 513 # Copy an entire image with no changes
 514 # - if an image has magic the copy of it will not be magical
 515
 516 sub copy {
 517   my $self = shift;
 518   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 519
 520   my $newcopy=Imager->new();
 521   $newcopy->{IMG}=i_img_new();
 522   i_copy($newcopy->{IMG},$self->{IMG});
 523   return $newcopy;
 524 }
 525
 526 # Paste a region
 527
 528 sub paste {
 529   my $self = shift;
 530   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 531   my %input=(left=>0, top=>0, @_);
 532   unless($input{img}) {
 533     $self->{ERRSTR}="no source image";
 534     return;
 535   }
 536   $input{left}=0 if $input{left} <= 0;
 537   $input{top}=0 if $input{top} <= 0;
 538   my $src=$input{img};
 539   my($r,$b)=i_img_info($src->{IMG});
 540
 541   i_copyto($self->{IMG}, $src->{IMG},
 542            0,0, $r, $b, $input{left}, $input{top});
 543   return $self;  # What should go here??
 544 }
 545
 546 # Crop an image - i.e. return a new image that is smaller
 547
 548 sub crop {
 549   my $self=shift;
 550   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 551   my %hsh=(left=>0,right=>0,top=>0,bottom=>0,@_);
 552
 553   my ($w,$h,$l,$r,$b,$t)=($self->getwidth(),$self->getheight(),
 554                                 @hsh{qw(left right bottom top)});
 555   $l=0 if not defined $l;
 556   $t=0 if not defined $t;
 557
 558   $r||=$l+delete $hsh{'width'}    if defined $l and exists $hsh{'width'};
 559   $b||=$t+delete $hsh{'height'}   if defined $t and exists $hsh{'height'};
 560   $l||=$r-delete $hsh{'width'}    if defined $r and exists $hsh{'width'};
 561   $t||=$b-delete $hsh{'height'}   if defined $b and exists $hsh{'height'};
 562
 563   $r=$self->getwidth if not defined $r;
 564   $b=$self->getheight if not defined $b;
 565
 566   ($l,$r)=($r,$l) if $l>$r;
 567   ($t,$b)=($b,$t) if $t>$b;
 568
 569   if ($hsh{'width'}) {
 570     $l=int(0.5+($w-$hsh{'width'})/2);
 571     $r=$l+$hsh{'width'};
 572   } else {
 573     $hsh{'width'}=$r-$l;
 574   }
 575   if ($hsh{'height'}) {
 576     $b=int(0.5+($h-$hsh{'height'})/2);
 577     $t=$h+$hsh{'height'};
 578   } else {
 579     $hsh{'height'}=$b-$t;
 580   }
 581
 582 #    print "l=$l, r=$r, h=$hsh{'width'}\n";
 583 #    print "t=$t, b=$b, w=$hsh{'height'}\n";
 584
 585   my $dst=Imager->new(xsize=>$hsh{'width'}, ysize=>$hsh{'height'}, channels=>$self->getchannels());
 586
 587   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
 588   return $dst;
 589 }
 590
 591 # Sets an image to a certain size and channel number
 592 # if there was previously data in the image it is discarded
 593
 594 sub img_set {
 595   my $self=shift;
 596
 597   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
 598
 599   if (defined($self->{IMG})) {
 600     # let IIM_DESTROY destroy it, it's possible this image is
 601     # referenced from a virtual image (like masked)
 602     #i_img_destroy($self->{IMG});
 603     undef($self->{IMG});
 604   }
 605
 606   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
 607     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
 608                                  $hsh{maxcolors} || 256);
 609   }
 610   elsif ($hsh{bits} eq 'double') {
 611     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 612   }
 613   elsif ($hsh{bits} == 16) {
 614     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 615   }
 616   else {
 617     $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
 618                                      $hsh{'channels'});
 619   }
 620 }
 621
 622 # created a masked version of the current image
 623 sub masked {
 624   my $self = shift;
 625
 626   $self or return undef;
 627   my %opts = (left    => 0,
 628               top     => 0,
 629               right   => $self->getwidth,
 630               bottom  => $self->getheight,
 631               @_);
 632   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
 633
 634   my $result = Imager->new;
 635   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
 636                                     $opts{top}, $opts{right} - $opts{left},
 637                                     $opts{bottom} - $opts{top});
 638   # keep references to the mask and base images so they don't
 639   # disappear on us
 640   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
 641
 642   $result;
 643 }
 644
 645 # convert an RGB image into a paletted image
 646 sub to_paletted {
 647   my $self = shift;
 648   my $opts;
 649   if (@_ != 1 && !ref $_[0]) {
 650     $opts = { @_ };
 651   }
 652   else {
 653     $opts = shift;
 654   }
 655
 656   my $result = Imager->new;
 657   $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
 658
 659   #print "Type ", i_img_type($result->{IMG}), "\n";
 660
 661   $result->{IMG} or undef $result;
 662
 663   return $result;
 664 }
 665
 666 # convert a paletted (or any image) to an 8-bit/channel RGB images
 667 sub to_rgb8 {
 668   my $self = shift;
 669   my $result;
 670
 671   if ($self->{IMG}) {
 672     $result = Imager->new;
 673     $result->{IMG} = i_img_to_rgb($self->{IMG})
 674       or undef $result;
 675   }
 676
 677   return $result;
 678 }
 679
 680 sub addcolors {
 681   my $self = shift;
 682   my %opts = (colors=>[], @_);
 683
 684   @{$opts{colors}} or return undef;
 685
 686   $self->{IMG} and i_addcolors($self->{IMG}, @{$opts{colors}});
 687 }
 688
 689 sub setcolors {
 690   my $self = shift;
 691   my %opts = (start=>0, colors=>[], @_);
 692   @{$opts{colors}} or return undef;
 693
 694   $self->{IMG} and i_setcolors($self->{IMG}, $opts{start}, @{$opts{colors}});
 695 }
 696
 697 sub getcolors {
 698   my $self = shift;
 699   my %opts = @_;
 700   if (!exists $opts{start} && !exists $opts{count}) {
 701     # get them all
 702     $opts{start} = 0;
 703     $opts{count} = $self->colorcount;
 704   }
 705   elsif (!exists $opts{count}) {
 706     $opts{count} = 1;
 707   }
 708   elsif (!exists $opts{start}) {
 709     $opts{start} = 0;
 710   }
 711
 712   $self->{IMG} and
 713     return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
 714 }
 715
 716 sub colorcount {
 717   i_colorcount($_[0]{IMG});
 718 }
 719
 720 sub maxcolors {
 721   i_maxcolors($_[0]{IMG});
 722 }
 723
 724 sub findcolor {
 725   my $self = shift;
 726   my %opts = @_;
 727   $opts{color} or return undef;
 728
 729   $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
 730 }
 731
 732 sub bits {
 733   my $self = shift;
 734   my $bits = $self->{IMG} && i_img_bits($self->{IMG});
 735   if ($bits && $bits == length(pack("d", 1)) * 8) {
 736     $bits = 'double';
 737   }
 738   $bits;
 739 }
 740
 741 sub type {
 742   my $self = shift;
 743   if ($self->{IMG}) {
 744     return i_img_type($self->{IMG}) ? "paletted" : "direct";
 745   }
 746 }
 747
 748 sub virtual {
 749   my $self = shift;
 750   $self->{IMG} and i_img_virtual($self->{IMG});
 751 }
 752
 753 sub tags {
 754   my ($self, %opts) = @_;
 755
 756   $self->{IMG} or return;
 757
 758   if (defined $opts{name}) {
 759     my @result;
 760     my $start = 0;
 761     my $found;
 762     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
 763       push @result, (i_tags_get($self->{IMG}, $found))[1];
 764       $start = $found+1;
 765     }
 766     return wantarray ? @result : $result[0];
 767   }
 768   elsif (defined $opts{code}) {
 769     my @result;
 770     my $start = 0;
 771     my $found;
 772     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
 773       push @result, (i_tags_get($self->{IMG}, $found))[1];
 774       $start = $found+1;
 775     }
 776     return @result;
 777   }
 778   else {
 779     if (wantarray) {
 780       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
 781     }
 782     else {
 783       return i_tags_count($self->{IMG});
 784     }
 785   }
 786 }
 787
 788 sub addtag {
 789   my $self = shift;
 790   my %opts = @_;
 791
 792   return -1 unless $self->{IMG};
 793   if ($opts{name}) {
 794     if (defined $opts{value}) {
 795       if ($opts{value} =~ /^\d+$/) {
 796         # add as a number
 797         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
 798       }
 799       else {
 800         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
 801       }
 802     }
 803     elsif (defined $opts{data}) {
 804       # force addition as a string
 805       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
 806     }
 807     else {
 808       $self->{ERRSTR} = "No value supplied";
 809       return undef;
 810     }
 811   }
 812   elsif ($opts{code}) {
 813     if (defined $opts{value}) {
 814       if ($opts{value} =~ /^\d+$/) {
 815         # add as a number
 816         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
 817       }
 818       else {
 819         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
 820       }
 821     }
 822     elsif (defined $opts{data}) {
 823       # force addition as a string
 824       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
 825     }
 826     else {
 827       $self->{ERRSTR} = "No value supplied";
 828       return undef;
 829     }
 830   }
 831   else {
 832     return undef;
 833   }
 834 }
 835
 836 sub deltag {
 837   my $self = shift;
 838   my %opts = @_;
 839
 840   return 0 unless $self->{IMG};
 841
 842   if (defined $opts{'index'}) {
 843     return i_tags_delete($self->{IMG}, $opts{'index'});
 844   }
 845   elsif (defined $opts{name}) {
 846     return i_tags_delbyname($self->{IMG}, $opts{name});
 847   }
 848   elsif (defined $opts{code}) {
 849     return i_tags_delbycode($self->{IMG}, $opts{code});
 850   }
 851   else {
 852     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
 853     return 0;
 854   }
 855 }
 856
 857 my @needseekcb = qw/tiff/;
 858 my %needseekcb = map { $_, $_ } @needseekcb;
 859
 860
 861 sub _get_reader_io {
 862   my ($self, $input, $type) = @_;
 863
 864   if ($input->{fd}) {
 865     return io_new_fd($input->{fd});
 866   }
 867   elsif ($input->{fh}) {
 868     my $fd = fileno($input->{fh});
 869     unless ($fd) {
 870       $self->_set_error("Handle in fh option not opened");
 871       return;
 872     }
 873     return io_new_fd($fd);
 874   }
 875   elsif ($input->{file}) {
 876     my $file = IO::File->new($input->{file}, "r");
 877     unless ($file) {
 878       $self->_set_error("Could not open $input->{file}: $!");
 879       return;
 880     }
 881     binmode $file;
 882     return (io_new_fd(fileno($file)), $file);
 883   }
 884   elsif ($input->{data}) {
 885     return io_new_buffer($input->{data});
 886   }
 887   elsif ($input->{callback} || $input->{readcb}) {
 888     if ($needseekcb{$type} && !$input->{seekcb}) {
 889       $self->_set_error("Format $type needs a seekcb parameter");
 890     }
 891     if ($input->{maxbuffer}) {
 892       return io_new_cb($input->{writecb},
 893                        $input->{callback} || $input->{readcb},
 894                        $input->{seekcb}, $input->{closecb},
 895                        $input->{maxbuffer});
 896     }
 897     else {
 898       return io_new_cb($input->{writecb},
 899                        $input->{callback} || $input->{readcb},
 900                        $input->{seekcb}, $input->{closecb});
 901     }
 902   }
 903   else {
 904     $self->_set_error("file/fd/fh/data/callback parameter missing");
 905     return;
 906   }
 907 }
 908
 909 sub _get_writer_io {
 910   my ($self, $input, $type) = @_;
 911
 912   if ($input->{fd}) {
 913     return io_new_fd($input->{fd});
 914   }
 915   elsif ($input->{fh}) {
 916     my $fd = fileno($input->{fh});
 917     unless ($fd) {
 918       $self->_set_error("Handle in fh option not opened");
 919       return;
 920     }
 921     return io_new_fd($fd);
 922   }
 923   elsif ($input->{file}) {
 924     my $fh = new IO::File($input->{file},"w+");
 925     unless ($fh) {
 926       $self->_set_error("Could not open file $input->{file}: $!");
 927       return;
 928     }
 929     binmode($fh) or die;
 930     return (io_new_fd(fileno($fh)), $fh);
 931   }
 932   elsif ($input->{data}) {
 933     return io_new_bufchain();
 934   }
 935   elsif ($input->{callback} || $input->{writecb}) {
 936     if ($input->{maxbuffer}) {
 937       return io_new_cb($input->{callback} || $input->{writecb},
 938                        $input->{readcb},
 939                        $input->{seekcb}, $input->{closecb},
 940                        $input->{maxbuffer});
 941     }
 942     else {
 943       return io_new_cb($input->{callback} || $input->{writecb},
 944                        $input->{readcb},
 945                        $input->{seekcb}, $input->{closecb});
 946     }
 947   }
 948   else {
 949     $self->_set_error("file/fd/fh/data/callback parameter missing");
 950     return;
 951   }
 952 }
 953
 954 # Read an image from file
 955
 956 sub read {
 957   my $self = shift;
 958   my %input=@_;
 959
 960   if (defined($self->{IMG})) {
 961     # let IIM_DESTROY do the destruction, since the image may be
 962     # referenced from elsewhere
 963     #i_img_destroy($self->{IMG});
 964     undef($self->{IMG});
 965   }
 966
 967   # FIXME: Find the format here if not specified
 968   # yes the code isn't here yet - next week maybe?
 969   # Next week?  Are you high or something?  That comment
 970   # has been there for half a year dude.
 971   # Look, i just work here, ok?
 972
 973   if (!$input{'type'} and $input{file}) {
 974     $input{'type'}=$FORMATGUESS->($input{file});
 975   }
 976   unless ($input{'type'}) {
 977     $self->_set_error('type parameter missing and not possible to guess from extension');
 978     return undef;
 979   }
 980   if (!$formats{$input{'type'}}) {
 981     $self->{ERRSTR}='format not supported'; return undef;
 982   }
 983
 984   my %iolready=(jpeg=>1, png=>1, tiff=>1, pnm=>1, raw=>1, bmp=>1, tga=>1, rgb=>1, gif=>1);
 985
 986   if ($iolready{$input{'type'}}) {
 987     # Setup data source
 988     my ($IO, $fh) = $self->_get_reader_io(\%input, $input{'type'})
 989       or return;
 990
 991     if ( $input{'type'} eq 'jpeg' ) {
 992       ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_wiol( $IO );
 993       if ( !defined($self->{IMG}) ) {
 994         $self->{ERRSTR}='unable to read jpeg image'; return undef;
 995       }
 996       $self->{DEBUG} && print "loading a jpeg file\n";
 997       return $self;
 998     }
 999
1000     if ( $input{'type'} eq 'tiff' ) {
1001       $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1002       if ( !defined($self->{IMG}) ) {
1003         $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1004       }
1005       $self->{DEBUG} && print "loading a tiff file\n";
1006       return $self;
1007     }
1008
1009     if ( $input{'type'} eq 'pnm' ) {
1010       $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1011       if ( !defined($self->{IMG}) ) {
1012         $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
1013       }
1014       $self->{DEBUG} && print "loading a pnm file\n";
1015       return $self;
1016     }
1017
1018     if ( $input{'type'} eq 'png' ) {
1019       $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1020       if ( !defined($self->{IMG}) ) {
1021         $self->{ERRSTR}='unable to read png image';
1022         return undef;
1023       }
1024       $self->{DEBUG} && print "loading a png file\n";
1025     }
1026
1027     if ( $input{'type'} eq 'bmp' ) {
1028       $self->{IMG}=i_readbmp_wiol( $IO );
1029       if ( !defined($self->{IMG}) ) {
1030         $self->{ERRSTR}=$self->_error_as_msg();
1031         return undef;
1032       }
1033       $self->{DEBUG} && print "loading a bmp file\n";
1034     }
1035
1036     if ( $input{'type'} eq 'gif' ) {
1037       if ($input{colors} && !ref($input{colors})) {
1038         # must be a reference to a scalar that accepts the colour map
1039         $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1040         return undef;
1041       }
1042       if ($input{colors}) {
1043         my $colors;
1044         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1045         if ($colors) {
1046           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1047         }
1048       }
1049       else {
1050         $self->{IMG} =i_readgif_wiol( $IO );
1051       }
1052       if ( !defined($self->{IMG}) ) {
1053         $self->{ERRSTR}=$self->_error_as_msg();
1054         return undef;
1055       }
1056       $self->{DEBUG} && print "loading a gif file\n";
1057     }
1058
1059     if ( $input{'type'} eq 'tga' ) {
1060       $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1061       if ( !defined($self->{IMG}) ) {
1062         $self->{ERRSTR}=$self->_error_as_msg();
1063         return undef;
1064       }
1065       $self->{DEBUG} && print "loading a tga file\n";
1066     }
1067
1068     if ( $input{'type'} eq 'rgb' ) {
1069       $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1070       if ( !defined($self->{IMG}) ) {
1071         $self->{ERRSTR}=$self->_error_as_msg();
1072         return undef;
1073       }
1074       $self->{DEBUG} && print "loading a tga file\n";
1075     }
1076
1077
1078     if ( $input{'type'} eq 'raw' ) {
1079       my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1080
1081       if ( !($params{xsize} && $params{ysize}) ) {
1082         $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1083         return undef;
1084       }
1085
1086       $self->{IMG} = i_readraw_wiol( $IO,
1087                                      $params{xsize},
1088                                      $params{ysize},
1089                                      $params{datachannels},
1090                                      $params{storechannels},
1091                                      $params{interleave});
1092       if ( !defined($self->{IMG}) ) {
1093         $self->{ERRSTR}='unable to read raw image';
1094         return undef;
1095       }
1096       $self->{DEBUG} && print "loading a raw file\n";
1097     }
1098
1099   } else {
1100
1101     # Old code for reference while changing the new stuff
1102
1103     if (!$input{'type'} and $input{file}) {
1104       $input{'type'}=$FORMATGUESS->($input{file});
1105     }
1106
1107     if (!$input{'type'}) {
1108       $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef;
1109     }
1110
1111     if (!$formats{$input{'type'}}) {
1112       $self->{ERRSTR}='format not supported';
1113       return undef;
1114     }
1115
1116     my ($fh, $fd);
1117     if ($input{file}) {
1118       $fh = new IO::File($input{file},"r");
1119       if (!defined $fh) {
1120         $self->{ERRSTR}='Could not open file';
1121         return undef;
1122       }
1123       binmode($fh);
1124       $fd = $fh->fileno();
1125     }
1126
1127     if ($input{fd}) {
1128       $fd=$input{fd};
1129     }
1130
1131     if ( $input{'type'} eq 'gif' ) {
1132       my $colors;
1133       if ($input{colors} && !ref($input{colors})) {
1134         # must be a reference to a scalar that accepts the colour map
1135         $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1136         return undef;
1137       }
1138       if (exists $input{data}) {
1139         if ($input{colors}) {
1140           ($self->{IMG}, $colors) = i_readgif_scalar($input{data});
1141         } else {
1142           $self->{IMG}=i_readgif_scalar($input{data});
1143         }
1144       } else {
1145         if ($input{colors}) {
1146           ($self->{IMG}, $colors) = i_readgif( $fd );
1147         } else {
1148           $self->{IMG} = i_readgif( $fd )
1149         }
1150       }
1151       if ($colors) {
1152         # we may or may not change i_readgif to return blessed objects...
1153         ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1154       }
1155       if ( !defined($self->{IMG}) ) {
1156         $self->{ERRSTR}= 'reading GIF:'._error_as_msg();
1157         return undef;
1158       }
1159       $self->{DEBUG} && print "loading a gif file\n";
1160     }
1161   }
1162   return $self;
1163 }
1164
1165 # Write an image to file
1166 sub write {
1167   my $self = shift;
1168   my %input=(jpegquality=>75,
1169              gifquant=>'mc',
1170              lmdither=>6.0,
1171              lmfixed=>[],
1172              idstring=>"",
1173              compress=>1,
1174              wierdpack=>0,
1175              fax_fine=>1, @_);
1176   my $rc;
1177
1178   my %iolready=( tiff=>1, raw=>1, png=>1, pnm=>1, bmp=>1, jpeg=>1, tga=>1,
1179                  gif=>1 ); # this will be SO MUCH BETTER once they are all in there
1180
1181   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1182
1183   if (!$input{'type'} and $input{file}) {
1184     $input{'type'}=$FORMATGUESS->($input{file});
1185   }
1186   if (!$input{'type'}) {
1187     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1188     return undef;
1189   }
1190
1191   if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
1192
1193   my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1194     or return undef;
1195
1196   # this conditional is probably obsolete
1197   if ($iolready{$input{'type'}}) {
1198
1199     if ($input{'type'} eq 'tiff') {
1200       if (defined $input{class} && $input{class} eq 'fax') {
1201         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1202           $self->{ERRSTR}='Could not write to buffer';
1203           return undef;
1204         }
1205       } else {
1206         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1207           $self->{ERRSTR}='Could not write to buffer';
1208           return undef;
1209         }
1210       }
1211     } elsif ( $input{'type'} eq 'pnm' ) {
1212       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1213         $self->{ERRSTR}='unable to write pnm image';
1214         return undef;
1215       }
1216       $self->{DEBUG} && print "writing a pnm file\n";
1217     } elsif ( $input{'type'} eq 'raw' ) {
1218       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1219         $self->{ERRSTR}='unable to write raw image';
1220         return undef;
1221       }
1222       $self->{DEBUG} && print "writing a raw file\n";
1223     } elsif ( $input{'type'} eq 'png' ) {
1224       if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1225         $self->{ERRSTR}='unable to write png image';
1226         return undef;
1227       }
1228       $self->{DEBUG} && print "writing a png file\n";
1229     } elsif ( $input{'type'} eq 'jpeg' ) {
1230       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1231         $self->{ERRSTR} = $self->_error_as_msg();
1232         return undef;
1233       }
1234       $self->{DEBUG} && print "writing a jpeg file\n";
1235     } elsif ( $input{'type'} eq 'bmp' ) {
1236       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1237         $self->{ERRSTR}='unable to write bmp image';
1238         return undef;
1239       }
1240       $self->{DEBUG} && print "writing a bmp file\n";
1241     } elsif ( $input{'type'} eq 'tga' ) {
1242
1243       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1244         $self->{ERRSTR}=$self->_error_as_msg();
1245         return undef;
1246       }
1247       $self->{DEBUG} && print "writing a tga file\n";
1248     } elsif ( $input{'type'} eq 'gif' ) {
1249       # compatibility with the old interfaces
1250       if ($input{gifquant} eq 'lm') {
1251         $input{make_colors} = 'addi';
1252         $input{translate} = 'perturb';
1253         $input{perturb} = $input{lmdither};
1254       } elsif ($input{gifquant} eq 'gen') {
1255         # just pass options through
1256       } else {
1257         $input{make_colors} = 'webmap'; # ignored
1258         $input{translate} = 'giflib';
1259       }
1260       $rc = i_writegif_wiol($IO, \%input, $self->{IMG});
1261     }
1262
1263     if (exists $input{'data'}) {
1264       my $data = io_slurp($IO);
1265       if (!$data) {
1266         $self->{ERRSTR}='Could not slurp from buffer';
1267         return undef;
1268       }
1269       ${$input{data}} = $data;
1270     }
1271     return $self;
1272   }
1273
1274   return $self;
1275 }
1276
1277 sub write_multi {
1278   my ($class, $opts, @images) = @_;
1279
1280   if (!$opts->{'type'} && $opts->{'file'}) {
1281     $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1282   }
1283   unless ($opts->{'type'}) {
1284     $class->_set_error('type parameter missing and not possible to guess from extension');
1285     return;
1286   }
1287   # translate to ImgRaw
1288   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1289     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1290     return 0;
1291   }
1292   my @work = map $_->{IMG}, @images;
1293   my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1294     or return undef;
1295   if ($opts->{'type'} eq 'gif') {
1296     my $gif_delays = $opts->{gif_delays};
1297     local $opts->{gif_delays} = $gif_delays;
1298     if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1299       # assume the caller wants the same delay for each frame
1300       $opts->{gif_delays} = [ ($gif_delays) x @images ];
1301     }
1302     my $res = i_writegif_wiol($IO, $opts, @work);
1303     $res or $class->_set_error($class->_error_as_msg());
1304     return $res;
1305   }
1306   elsif ($opts->{'type'} eq 'tiff') {
1307     my $res;
1308     $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1309     if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1310       $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1311     }
1312     else {
1313       $res = i_writetiff_multi_wiol($IO, @work);
1314     }
1315     $res or $class->_set_error($class->_error_as_msg());
1316     return $res;
1317   }
1318   else {
1319     $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
1320     return 0;
1321   }
1322 }
1323
1324 # read multiple images from a file
1325 sub read_multi {
1326   my ($class, %opts) = @_;
1327
1328   if ($opts{file} && !exists $opts{'type'}) {
1329     # guess the type
1330     my $type = $FORMATGUESS->($opts{file});
1331     $opts{'type'} = $type;
1332   }
1333   unless ($opts{'type'}) {
1334     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1335     return;
1336   }
1337
1338   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1339     or return;
1340   if ($opts{'type'} eq 'gif') {
1341     my @imgs;
1342     @imgs = i_readgif_multi_wiol($IO);
1343     if (@imgs) {
1344       return map {
1345         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1346       } @imgs;
1347     }
1348     else {
1349       $ERRSTR = _error_as_msg();
1350       return;
1351     }
1352   }
1353   elsif ($opts{'type'} eq 'tiff') {
1354     my @imgs = i_readtiff_multi_wiol($IO, -1);
1355     if (@imgs) {
1356       return map {
1357         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1358       } @imgs;
1359     }
1360     else {
1361       $ERRSTR = _error_as_msg();
1362       return;
1363     }
1364   }
1365
1366   $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
1367   return;
1368 }
1369
1370 # Destroy an Imager object
1371
1372 sub DESTROY {
1373   my $self=shift;
1374   #    delete $instances{$self};
1375   if (defined($self->{IMG})) {
1376     # the following is now handled by the XS DESTROY method for
1377     # Imager::ImgRaw object
1378     # Re-enabling this will break virtual images
1379     # tested for in t/t020masked.t
1380     # i_img_destroy($self->{IMG});
1381     undef($self->{IMG});
1382   } else {
1383 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1384   }
1385 }
1386
1387 # Perform an inplace filter of an image
1388 # that is the image will be overwritten with the data
1389
1390 sub filter {
1391   my $self=shift;
1392   my %input=@_;
1393   my %hsh;
1394   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1395
1396   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1397
1398   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1399     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1400   }
1401
1402   if ($filters{$input{'type'}}{names}) {
1403     my $names = $filters{$input{'type'}}{names};
1404     for my $name (keys %$names) {
1405       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1406         $input{$name} = $names->{$name}{$input{$name}};
1407       }
1408     }
1409   }
1410   if (defined($filters{$input{'type'}}{defaults})) {
1411     %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
1412   } else {
1413     %hsh=('image',$self->{IMG},%input);
1414   }
1415
1416   my @cs=@{$filters{$input{'type'}}{callseq}};
1417
1418   for(@cs) {
1419     if (!defined($hsh{$_})) {
1420       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1421     }
1422   }
1423
1424   &{$filters{$input{'type'}}{callsub}}(%hsh);
1425
1426   my @b=keys %hsh;
1427
1428   $self->{DEBUG} && print "callseq is: @cs\n";
1429   $self->{DEBUG} && print "matching callseq is: @b\n";
1430
1431   return $self;
1432 }
1433
1434 # Scale an image to requested size and return the scaled version
1435
1436 sub scale {
1437   my $self=shift;
1438   my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
1439   my $img = Imager->new();
1440   my $tmp = Imager->new();
1441
1442   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1443
1444   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
1445     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
1446     if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1447     if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
1448   } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1449   elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1450
1451   if ($opts{qtype} eq 'normal') {
1452     $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1453     if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1454     $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1455     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1456     return $img;
1457   }
1458   if ($opts{'qtype'} eq 'preview') {
1459     $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
1460     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1461     return $img;
1462   }
1463   $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1464 }
1465
1466 # Scales only along the X axis
1467
1468 sub scaleX {
1469   my $self=shift;
1470   my %opts=(scalefactor=>0.5,@_);
1471
1472   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1473
1474   my $img = Imager->new();
1475
1476   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1477
1478   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1479   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1480
1481   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1482   return $img;
1483 }
1484
1485 # Scales only along the Y axis
1486
1487 sub scaleY {
1488   my $self=shift;
1489   my %opts=(scalefactor=>0.5,@_);
1490
1491   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1492
1493   my $img = Imager->new();
1494
1495   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1496
1497   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1498   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1499
1500   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1501   return $img;
1502 }
1503
1504
1505 # Transform returns a spatial transformation of the input image
1506 # this moves pixels to a new location in the returned image.
1507 # NOTE - should make a utility function to check transforms for
1508 # stack overruns
1509
1510 sub transform {
1511   my $self=shift;
1512   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1513   my %opts=@_;
1514   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1515
1516 #  print Dumper(\%opts);
1517 #  xopcopdes
1518
1519   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1520     if (!$I2P) {
1521       eval ("use Affix::Infix2Postfix;");
1522       print $@;
1523       if ( $@ ) {
1524         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
1525         return undef;
1526       }
1527       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1528                                              {op=>'-',trans=>'Sub'},
1529                                              {op=>'*',trans=>'Mult'},
1530                                              {op=>'/',trans=>'Div'},
1531                                              {op=>'-','type'=>'unary',trans=>'u-'},
1532                                              {op=>'**'},
1533                                              {op=>'func','type'=>'unary'}],
1534                                      'grouping'=>[qw( \( \) )],
1535                                      'func'=>[qw( sin cos )],
1536                                      'vars'=>[qw( x y )]
1537                                     );
1538     }
1539
1540     @xt=$I2P->translate($opts{'xexpr'});
1541     @yt=$I2P->translate($opts{'yexpr'});
1542
1543     $numre=$I2P->{'numre'};
1544     @pt=(0,0);
1545
1546     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1547     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1548     @{$opts{'parm'}}=@pt;
1549   }
1550
1551 #  print Dumper(\%opts);
1552
1553   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1554     $self->{ERRSTR}='transform: no xopcodes given.';
1555     return undef;
1556   }
1557
1558   @op=@{$opts{'xopcodes'}};
1559   for $iop (@op) {
1560     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1561       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1562       return undef;
1563     }
1564     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1565   }
1566
1567
1568 # yopcopdes
1569
1570   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1571     $self->{ERRSTR}='transform: no yopcodes given.';
1572     return undef;
1573   }
1574
1575   @op=@{$opts{'yopcodes'}};
1576   for $iop (@op) {
1577     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1578       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1579       return undef;
1580     }
1581     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1582   }
1583
1584 #parameters
1585
1586   if ( !exists $opts{'parm'}) {
1587     $self->{ERRSTR}='transform: no parameter arg given.';
1588     return undef;
1589   }
1590
1591 #  print Dumper(\@ropx);
1592 #  print Dumper(\@ropy);
1593 #  print Dumper(\@ropy);
1594
1595   my $img = Imager->new();
1596   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1597   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1598   return $img;
1599 }
1600
1601
1602 sub transform2 {
1603   my ($opts, @imgs) = @_;
1604
1605   require "Imager/Expr.pm";
1606
1607   $opts->{variables} = [ qw(x y) ];
1608   my ($width, $height) = @{$opts}{qw(width height)};
1609   if (@imgs) {
1610     $width ||= $imgs[0]->getwidth();
1611     $height ||= $imgs[0]->getheight();
1612     my $img_num = 1;
1613     for my $img (@imgs) {
1614       $opts->{constants}{"w$img_num"} = $img->getwidth();
1615       $opts->{constants}{"h$img_num"} = $img->getheight();
1616       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1617       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1618       ++$img_num;
1619     }
1620   }
1621   if ($width) {
1622     $opts->{constants}{w} = $width;
1623     $opts->{constants}{cx} = $width/2;
1624   }
1625   else {
1626     $Imager::ERRSTR = "No width supplied";
1627     return;
1628   }
1629   if ($height) {
1630     $opts->{constants}{h} = $height;
1631     $opts->{constants}{cy} = $height/2;
1632   }
1633   else {
1634     $Imager::ERRSTR = "No height supplied";
1635     return;
1636   }
1637   my $code = Imager::Expr->new($opts);
1638   if (!$code) {
1639     $Imager::ERRSTR = Imager::Expr::error();
1640     return;
1641   }
1642
1643   my $img = Imager->new();
1644   $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, $code->code(),
1645                              $code->nregs(), $code->cregs(),
1646                              [ map { $_->{IMG} } @imgs ]);
1647   if (!defined $img->{IMG}) {
1648     $Imager::ERRSTR = Imager->_error_as_msg();
1649     return;
1650   }
1651
1652   return $img;
1653 }
1654
1655 sub rubthrough {
1656   my $self=shift;
1657   my %opts=(tx=>0,ty=>0,@_);
1658
1659   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1660   unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1661
1662   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx},$opts{ty})) {
1663     $self->{ERRSTR} = $self->_error_as_msg();
1664     return undef;
1665   }
1666   return $self;
1667 }
1668
1669
1670 sub flip {
1671   my $self  = shift;
1672   my %opts  = @_;
1673   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
1674   my $dir;
1675   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1676   $dir = $xlate{$opts{'dir'}};
1677   return $self if i_flipxy($self->{IMG}, $dir);
1678   return ();
1679 }
1680
1681 sub rotate {
1682   my $self = shift;
1683   my %opts = @_;
1684   if (defined $opts{right}) {
1685     my $degrees = $opts{right};
1686     if ($degrees < 0) {
1687       $degrees += 360 * int(((-$degrees)+360)/360);
1688     }
1689     $degrees = $degrees % 360;
1690     if ($degrees == 0) {
1691       return $self->copy();
1692     }
1693     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1694       my $result = Imager->new();
1695       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1696         return $result;
1697       }
1698       else {
1699         $self->{ERRSTR} = $self->_error_as_msg();
1700         return undef;
1701       }
1702     }
1703     else {
1704       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1705       return undef;
1706     }
1707   }
1708   elsif (defined $opts{radians} || defined $opts{degrees}) {
1709     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1710
1711     my $result = Imager->new;
1712     if ($result->{IMG} = i_rotate_exact($self->{IMG}, $amount)) {
1713       return $result;
1714     }
1715     else {
1716       $self->{ERRSTR} = $self->_error_as_msg();
1717       return undef;
1718     }
1719   }
1720   else {
1721     $self->{ERRSTR} = "Only the 'right' parameter is available";
1722     return undef;
1723   }
1724 }
1725
1726 sub matrix_transform {
1727   my $self = shift;
1728   my %opts = @_;
1729
1730   if ($opts{matrix}) {
1731     my $xsize = $opts{xsize} || $self->getwidth;
1732     my $ysize = $opts{ysize} || $self->getheight;
1733
1734     my $result = Imager->new;
1735     $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1736                                         $opts{matrix})
1737       or return undef;
1738
1739     return $result;
1740   }
1741   else {
1742     $self->{ERRSTR} = "matrix parameter required";
1743     return undef;
1744   }
1745 }
1746
1747 # blame Leolo :)
1748 *yatf = \&matrix_transform;
1749
1750 # These two are supported for legacy code only
1751
1752 sub i_color_new {
1753   return Imager::Color->new(@_);
1754 }
1755
1756 sub i_color_set {
1757   return Imager::Color::set(@_);
1758 }
1759
1760 # Draws a box between the specified corner points.
1761 sub box {
1762   my $self=shift;
1763   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1764   my $dflcl=i_color_new(255,255,255,255);
1765   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1766
1767   if (exists $opts{'box'}) {
1768     $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1769     $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1770     $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1771     $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1772   }
1773
1774   if ($opts{filled}) {
1775     my $color = _color($opts{'color'});
1776     unless ($color) {
1777       $self->{ERRSTR} = $Imager::ERRSTR;
1778       return;
1779     }
1780     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1781                  $opts{ymax}, $color);
1782   }
1783   elsif ($opts{fill}) {
1784     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1785       # assume it's a hash ref
1786       require 'Imager/Fill.pm';
1787       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1788         $self->{ERRSTR} = $Imager::ERRSTR;
1789         return undef;
1790       }
1791     }
1792     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1793                 $opts{ymax},$opts{fill}{fill});
1794   }
1795   else {
1796     my $color = _color($opts{'color'});
1797     unless ($color) {
1798       $self->{ERRSTR} = $Imager::ERRSTR;
1799       return;
1800     }
1801     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
1802           $color);
1803   }
1804   return $self;
1805 }
1806
1807 # Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
1808
1809 sub arc {
1810   my $self=shift;
1811   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1812   my $dflcl=i_color_new(255,255,255,255);
1813   my %opts=(color=>$dflcl,
1814             'r'=>min($self->getwidth(),$self->getheight())/3,
1815             'x'=>$self->getwidth()/2,
1816             'y'=>$self->getheight()/2,
1817             'd1'=>0, 'd2'=>361, @_);
1818   if ($opts{fill}) {
1819     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1820       # assume it's a hash ref
1821       require 'Imager/Fill.pm';
1822       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1823         $self->{ERRSTR} = $Imager::ERRSTR;
1824         return;
1825       }
1826     }
1827     i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
1828                 $opts{'d2'}, $opts{fill}{fill});
1829   }
1830   else {
1831     my $color = _color($opts{'color'});
1832     unless ($color) {
1833       $self->{ERRSTR} = $Imager::ERRSTR;
1834       return;
1835     }
1836     if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
1837       i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
1838                   $color);
1839     }
1840     else {
1841       if ($opts{'d1'} <= $opts{'d2'}) {
1842         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1843               $opts{'d1'}, $opts{'d2'}, $color);
1844       }
1845       else {
1846         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1847               $opts{'d1'}, 361,         $color);
1848         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1849               0,           $opts{'d2'}, $color);
1850       }
1851     }
1852   }
1853
1854   return $self;
1855 }
1856
1857 # Draws a line from one point to (but not including) the destination point
1858
1859 sub line {
1860   my $self=shift;
1861   my $dflcl=i_color_new(0,0,0,0);
1862   my %opts=(color=>$dflcl,@_);
1863   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1864
1865   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
1866   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
1867
1868   my $color = _color($opts{'color'});
1869   unless ($color) {
1870     $self->{ERRSTR} = $Imager::ERRSTR;
1871     return;
1872   }
1873   $opts{antialias} = $opts{aa} if defined $opts{aa};
1874   if ($opts{antialias}) {
1875     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
1876               $color);
1877   } else {
1878     i_draw($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
1879            $color);
1880   }
1881   return $self;
1882 }
1883
1884 # Draws a line between an ordered set of points - It more or less just transforms this
1885 # into a list of lines.
1886
1887 sub polyline {
1888   my $self=shift;
1889   my ($pt,$ls,@points);
1890   my $dflcl=i_color_new(0,0,0,0);
1891   my %opts=(color=>$dflcl,@_);
1892
1893   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1894
1895   if (exists($opts{points})) { @points=@{$opts{points}}; }
1896   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
1897     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
1898     }
1899
1900 #  print Dumper(\@points);
1901
1902   my $color = _color($opts{'color'});
1903   unless ($color) {
1904     $self->{ERRSTR} = $Imager::ERRSTR;
1905     return;
1906   }
1907   $opts{antialias} = $opts{aa} if defined $opts{aa};
1908   if ($opts{antialias}) {
1909     for $pt(@points) {
1910       if (defined($ls)) {
1911         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
1912       }
1913       $ls=$pt;
1914     }
1915   } else {
1916     for $pt(@points) {
1917       if (defined($ls)) {
1918         i_draw($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
1919       }
1920       $ls=$pt;
1921     }
1922   }
1923   return $self;
1924 }
1925
1926 sub polygon {
1927   my $self = shift;
1928   my ($pt,$ls,@points);
1929   my $dflcl = i_color_new(0,0,0,0);
1930   my %opts = (color=>$dflcl, @_);
1931
1932   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1933
1934   if (exists($opts{points})) {
1935     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
1936     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
1937   }
1938
1939   if (!exists $opts{'x'} or !exists $opts{'y'})  {
1940     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
1941   }
1942
1943   if ($opts{'fill'}) {
1944     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
1945       # assume it's a hash ref
1946       require 'Imager/Fill.pm';
1947       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
1948         $self->{ERRSTR} = $Imager::ERRSTR;
1949         return undef;
1950       }
1951     }
1952     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
1953                     $opts{'fill'}{'fill'});
1954   }
1955   else {
1956     my $color = _color($opts{'color'});
1957     unless ($color) {
1958       $self->{ERRSTR} = $Imager::ERRSTR;
1959       return;
1960     }
1961     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
1962   }
1963
1964   return $self;
1965 }
1966
1967
1968 # this the multipoint bezier curve
1969 # this is here more for testing that actual usage since
1970 # this is not a good algorithm.  Usually the curve would be
1971 # broken into smaller segments and each done individually.
1972
1973 sub polybezier {
1974   my $self=shift;
1975   my ($pt,$ls,@points);
1976   my $dflcl=i_color_new(0,0,0,0);
1977   my %opts=(color=>$dflcl,@_);
1978
1979   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1980
1981   if (exists $opts{points}) {
1982     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
1983     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
1984   }
1985
1986   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
1987     $self->{ERRSTR}='Missing or invalid points.';
1988     return;
1989   }
1990
1991   my $color = _color($opts{'color'});
1992   unless ($color) {
1993     $self->{ERRSTR} = $Imager::ERRSTR;
1994     return;
1995   }
1996   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
1997   return $self;
1998 }
1999
2000 sub flood_fill {
2001   my $self = shift;
2002   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2003
2004   unless (exists $opts{'x'} && exists $opts{'y'}) {
2005     $self->{ERRSTR} = "missing seed x and y parameters";
2006     return undef;
2007   }
2008
2009   if ($opts{fill}) {
2010     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2011       # assume it's a hash ref
2012       require 'Imager/Fill.pm';
2013       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2014         $self->{ERRSTR} = $Imager::ERRSTR;
2015         return;
2016       }
2017     }
2018     i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2019   }
2020   else {
2021     my $color = _color($opts{'color'});
2022     unless ($color) {
2023       $self->{ERRSTR} = $Imager::ERRSTR;
2024       return;
2025     }
2026     i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2027   }
2028
2029   $self;
2030 }
2031
2032 sub setpixel {
2033   my $self = shift;
2034
2035   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2036
2037   unless (exists $opts{'x'} && exists $opts{'y'}) {
2038     $self->{ERRSTR} = 'missing x and y parameters';
2039     return undef;
2040   }
2041
2042   my $x = $opts{'x'};
2043   my $y = $opts{'y'};
2044   my $color = _color($opts{color})
2045     or return undef;
2046   if (ref $x && ref $y) {
2047     unless (@$x == @$y) {
2048       $self->{ERRSTR} = 'length of x and y mistmatch';
2049       return undef;
2050     }
2051     if ($color->isa('Imager::Color')) {
2052       for my $i (0..$#{$opts{'x'}}) {
2053         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2054       }
2055     }
2056     else {
2057       for my $i (0..$#{$opts{'x'}}) {
2058         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2059       }
2060     }
2061   }
2062   else {
2063     if ($color->isa('Imager::Color')) {
2064       i_ppix($self->{IMG}, $x, $y, $color);
2065     }
2066     else {
2067       i_ppixf($self->{IMG}, $x, $y, $color);
2068     }
2069   }
2070
2071   $self;
2072 }
2073
2074 sub getpixel {
2075   my $self = shift;
2076
2077   my %opts = ( type=>'8bit', @_);
2078
2079   unless (exists $opts{'x'} && exists $opts{'y'}) {
2080     $self->{ERRSTR} = 'missing x and y parameters';
2081     return undef;
2082   }
2083
2084   my $x = $opts{'x'};
2085   my $y = $opts{'y'};
2086   if (ref $x && ref $y) {
2087     unless (@$x == @$y) {
2088       $self->{ERRSTR} = 'length of x and y mismatch';
2089       return undef;
2090     }
2091     my @result;
2092     if ($opts{type} eq '8bit') {
2093       for my $i (0..$#{$opts{'x'}}) {
2094         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2095       }
2096     }
2097     else {
2098       for my $i (0..$#{$opts{'x'}}) {
2099         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2100       }
2101     }
2102     return wantarray ? @result : \@result;
2103   }
2104   else {
2105     if ($opts{type} eq '8bit') {
2106       return i_get_pixel($self->{IMG}, $x, $y);
2107     }
2108     else {
2109       return i_gpixf($self->{IMG}, $x, $y);
2110     }
2111   }
2112
2113   $self;
2114 }
2115
2116 # make an identity matrix of the given size
2117 sub _identity {
2118   my ($size) = @_;
2119
2120   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2121   for my $c (0 .. ($size-1)) {
2122     $matrix->[$c][$c] = 1;
2123   }
2124   return $matrix;
2125 }
2126
2127 # general function to convert an image
2128 sub convert {
2129   my ($self, %opts) = @_;
2130   my $matrix;
2131
2132   # the user can either specify a matrix or preset
2133   # the matrix overrides the preset
2134   if (!exists($opts{matrix})) {
2135     unless (exists($opts{preset})) {
2136       $self->{ERRSTR} = "convert() needs a matrix or preset";
2137       return;
2138     }
2139     else {
2140       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2141         # convert to greyscale, keeping the alpha channel if any
2142         if ($self->getchannels == 3) {
2143           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2144         }
2145         elsif ($self->getchannels == 4) {
2146           # preserve the alpha channel
2147           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2148                       [ 0,     0,     0,     1 ] ];
2149         }
2150         else {
2151           # an identity
2152           $matrix = _identity($self->getchannels);
2153         }
2154       }
2155       elsif ($opts{preset} eq 'noalpha') {
2156         # strip the alpha channel
2157         if ($self->getchannels == 2 or $self->getchannels == 4) {
2158           $matrix = _identity($self->getchannels);
2159           pop(@$matrix); # lose the alpha entry
2160         }
2161         else {
2162           $matrix = _identity($self->getchannels);
2163         }
2164       }
2165       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2166         # extract channel 0
2167         $matrix = [ [ 1 ] ];
2168       }
2169       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2170         $matrix = [ [ 0, 1 ] ];
2171       }
2172       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2173         $matrix = [ [ 0, 0, 1 ] ];
2174       }
2175       elsif ($opts{preset} eq 'alpha') {
2176         if ($self->getchannels == 2 or $self->getchannels == 4) {
2177           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2178         }
2179         else {
2180           # the alpha is just 1 <shrug>
2181           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2182         }
2183       }
2184       elsif ($opts{preset} eq 'rgb') {
2185         if ($self->getchannels == 1) {
2186           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2187         }
2188         elsif ($self->getchannels == 2) {
2189           # preserve the alpha channel
2190           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2191         }
2192         else {
2193           $matrix = _identity($self->getchannels);
2194         }
2195       }
2196       elsif ($opts{preset} eq 'addalpha') {
2197         if ($self->getchannels == 1) {
2198           $matrix = _identity(2);
2199         }
2200         elsif ($self->getchannels == 3) {
2201           $matrix = _identity(4);
2202         }
2203         else {
2204           $matrix = _identity($self->getchannels);
2205         }
2206       }
2207       else {
2208         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2209         return undef;
2210       }
2211     }
2212   }
2213   else {
2214     $matrix = $opts{matrix};
2215   }
2216
2217   my $new = Imager->new();
2218   $new->{IMG} = i_img_new();
2219   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2220     # most likely a bad matrix
2221     $self->{ERRSTR} = _error_as_msg();
2222     return undef;
2223   }
2224   return $new;
2225 }
2226
2227
2228 # general function to map an image through lookup tables
2229
2230 sub map {
2231   my ($self, %opts) = @_;
2232   my @chlist = qw( red green blue alpha );
2233
2234   if (!exists($opts{'maps'})) {
2235     # make maps from channel maps
2236     my $chnum;
2237     for $chnum (0..$#chlist) {
2238       if (exists $opts{$chlist[$chnum]}) {
2239         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2240       } elsif (exists $opts{'all'}) {
2241         $opts{'maps'}[$chnum] = $opts{'all'};
2242       }
2243     }
2244   }
2245   if ($opts{'maps'} and $self->{IMG}) {
2246     i_map($self->{IMG}, $opts{'maps'} );
2247   }
2248   return $self;
2249 }
2250
2251 # destructive border - image is shrunk by one pixel all around
2252
2253 sub border {
2254   my ($self,%opts)=@_;
2255   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2256   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2257 }
2258
2259
2260 # Get the width of an image
2261
2262 sub getwidth {
2263   my $self = shift;
2264   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2265   return (i_img_info($self->{IMG}))[0];
2266 }
2267
2268 # Get the height of an image
2269
2270 sub getheight {
2271   my $self = shift;
2272   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2273   return (i_img_info($self->{IMG}))[1];
2274 }
2275
2276 # Get number of channels in an image
2277
2278 sub getchannels {
2279   my $self = shift;
2280   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2281   return i_img_getchannels($self->{IMG});
2282 }
2283
2284 # Get channel mask
2285
2286 sub getmask {
2287   my $self = shift;
2288   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2289   return i_img_getmask($self->{IMG});
2290 }
2291
2292 # Set channel mask
2293
2294 sub setmask {
2295   my $self = shift;
2296   my %opts = @_;
2297   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2298   i_img_setmask( $self->{IMG} , $opts{mask} );
2299 }
2300
2301 # Get number of colors in an image
2302
2303 sub getcolorcount {
2304   my $self=shift;
2305   my %opts=('maxcolors'=>2**30,@_);
2306   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2307   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2308   return ($rc==-1? undef : $rc);
2309 }
2310
2311 # draw string to an image
2312
2313 sub string {
2314   my $self = shift;
2315   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2316
2317   my %input=('x'=>0, 'y'=>0, @_);
2318   $input{string}||=$input{text};
2319
2320   unless(exists $input{string}) {
2321     $self->{ERRSTR}="missing required parameter 'string'";
2322     return;
2323   }
2324
2325   unless($input{font}) {
2326     $self->{ERRSTR}="missing required parameter 'font'";
2327     return;
2328   }
2329
2330   unless ($input{font}->draw(image=>$self, %input)) {
2331     $self->{ERRSTR} = $self->_error_as_msg();
2332     return;
2333   }
2334
2335   return $self;
2336 }
2337
2338 # Shortcuts that can be exported
2339
2340 sub newcolor { Imager::Color->new(@_); }
2341 sub newfont  { Imager::Font->new(@_); }
2342
2343 *NC=*newcolour=*newcolor;
2344 *NF=*newfont;
2345
2346 *open=\&read;
2347 *circle=\&arc;
2348
2349
2350 #### Utility routines
2351
2352 sub errstr {
2353   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2354 }
2355
2356 sub _set_error {
2357   my ($self, $msg) = @_;
2358
2359   if (ref $self) {
2360     $self->{ERRSTR} = $msg;
2361   }
2362   else {
2363     $ERRSTR = $msg;
2364   }
2365 }
2366
2367 # Default guess for the type of an image from extension
2368
2369 sub def_guess_type {
2370   my $name=lc(shift);
2371   my $ext;
2372   $ext=($name =~ m/\.([^\.]+)$/)[0];
2373   return 'tiff' if ($ext =~ m/^tiff?$/);
2374   return 'jpeg' if ($ext =~ m/^jpe?g$/);
2375   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
2376   return 'png'  if ($ext eq "png");
2377   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
2378   return 'tga'  if ($ext eq "tga");
2379   return 'rgb'  if ($ext eq "rgb");
2380   return 'gif'  if ($ext eq "gif");
2381   return 'raw'  if ($ext eq "raw");
2382   return ();
2383 }
2384
2385 # get the minimum of a list
2386
2387 sub min {
2388   my $mx=shift;
2389   for(@_) { if ($_<$mx) { $mx=$_; }}
2390   return $mx;
2391 }
2392
2393 # get the maximum of a list
2394
2395 sub max {
2396   my $mx=shift;
2397   for(@_) { if ($_>$mx) { $mx=$_; }}
2398   return $mx;
2399 }
2400
2401 # string stuff for iptc headers
2402
2403 sub clean {
2404   my($str)=$_[0];
2405   $str = substr($str,3);
2406   $str =~ s/[\n\r]//g;
2407   $str =~ s/\s+/ /g;
2408   $str =~ s/^\s//;
2409   $str =~ s/\s$//;
2410   return $str;
2411 }
2412
2413 # A little hack to parse iptc headers.
2414
2415 sub parseiptc {
2416   my $self=shift;
2417   my(@sar,$item,@ar);
2418   my($caption,$photogr,$headln,$credit);
2419
2420   my $str=$self->{IPTCRAW};
2421
2422   #print $str;
2423
2424   @ar=split(/8BIM/,$str);
2425
2426   my $i=0;
2427   foreach (@ar) {
2428     if (/^\004\004/) {
2429       @sar=split(/\034\002/);
2430       foreach $item (@sar) {
2431         if ($item =~ m/^x/) {
2432           $caption=&clean($item);
2433           $i++;
2434         }
2435         if ($item =~ m/^P/) {
2436           $photogr=&clean($item);
2437           $i++;
2438         }
2439         if ($item =~ m/^i/) {
2440           $headln=&clean($item);
2441           $i++;
2442         }
2443         if ($item =~ m/^n/) {
2444           $credit=&clean($item);
2445           $i++;
2446         }
2447       }
2448     }
2449   }
2450   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2451 }
2452
2453 # Autoload methods go after =cut, and are processed by the autosplit program.
2454
2455 1;
2456 __END__
2457 # Below is the stub of documentation for your module. You better edit it!
2458
2459 =head1 NAME
2460
2461 Imager - Perl extension for Generating 24 bit Images
2462
2463 =head1 SYNOPSIS
2464
2465   # Thumbnail example
2466
2467   #!/usr/bin/perl -w
2468   use strict;
2469   use Imager;
2470
2471   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2472   my $file = shift;
2473
2474   my $format;
2475
2476   my $img = Imager->new();
2477   $img->open(file=>$file) or die $img->errstr();
2478
2479   $file =~ s/\.[^.]*$//;
2480
2481   # Create smaller version
2482   my $thumb = $img->scale(scalefactor=>.3);
2483
2484   # Autostretch individual channels
2485   $thumb->filter(type=>'autolevels');
2486
2487   # try to save in one of these formats
2488   SAVE:
2489
2490   for $format ( qw( png gif jpg tiff ppm ) ) {
2491     # Check if given format is supported
2492     if ($Imager::formats{$format}) {
2493       $file.="_low.$format";
2494       print "Storing image as: $file\n";
2495       $thumb->write(file=>$file) or
2496         die $thumb->errstr;
2497       last SAVE;
2498     }
2499   }
2500
2501
2502   # Logo Generator Example
2503
2504
2505
2506 =head1 DESCRIPTION
2507
2508 Imager is a module for creating and altering images.  It can read and
2509 write various image formats, draw primitive shapes like lines,and
2510 polygons, blend multiple images together in various ways, scale, crop,
2511 render text and more.
2512
2513 =head2 Overview of documentation
2514
2515 =over
2516
2517 =item Imager
2518
2519 This document - Synopsis Example, Table of Contents and Overview.
2520
2521 =item Imager::ImageTypes
2522
2523 Direct type/virtual images, RGB(A)/paletted images, 8/16/double
2524 bits/channel, color maps, channel masks, image tags, color
2525 quantization.
2526
2527 =item Imager::Files
2528
2529 IO interaction, reading/writing images, format specific tags.
2530
2531 =item Imager::Draw
2532
2533 Drawing Primitives, lines, boxes, circles, arcs, flood fill.
2534
2535 =item Imager::Color
2536
2537 Color specification.
2538
2539 =item Imager::Fill
2540
2541 Fill pattern specification.
2542
2543 =item Imager::Font
2544
2545 General font rendering, bounding boxes and font metrics.
2546
2547 =item Imager::Transformations
2548
2549 Copying, scaling, cropping, flipping, blending, pasting, convert and
2550 map.
2551
2552 =item Imager::Engines
2553
2554 Programmable transformations through C<transform()>, C<transform2()>
2555 and C<matrix_transform()>.
2556
2557 =item Imager::Filters
2558
2559 Filters, sharpen, blur, noise, convolve etc. and filter plugins.
2560
2561 =item Imager::Expr
2562
2563 Expressions for evaluation engine used by transform2().
2564
2565 =item Imager::Matrix2d
2566
2567 Helper class for affine transformations.
2568
2569 =item Imager::Fountain
2570
2571 Helper for making gradient profiles.
2572
2573 =back
2574
2575
2576
2577 =head2 Basic Overview
2578
2579 An Image object is created with C<$img = Imager-E<gt>new()> Should
2580 this fail for some reason an explanation can be found in
2581 C<$Imager::ERRSTR> usually error messages are stored in
2582 C<$img-E<gt>{ERRSTR}>, but since no object is created this is the only
2583 way to give back errors.  C<$Imager::ERRSTR> is also used to report
2584 all errors not directly associated with an image object. Examples:
2585
2586   $img=Imager->new(); # This is an empty image (size is 0 by 0)
2587   $img->open(file=>'lena.png',type=>'png'); # initializes from file
2588
2589 or if you want to create an empty image:
2590
2591   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2592
2593 This example creates a completely black image of width 400 and height
2594 300 and 4 channels.
2595
2596 =head1 SUPPORT
2597
2598 You can ask for help, report bugs or express your undying love for
2599 Imager on the Imager-devel mailing list.
2600
2601 To subscribe send a message with C<subscribe> in the body to:
2602
2603    imager-devel+request@molar.is
2604
2605 or use the form at:
2606
2607    http://www.molar.is/en/lists/imager-devel/
2608
2609 where you can also find the mailing list archive.
2610
2611 =head1 BUGS
2612
2613 Bugs are listed individually for relevant pod pages.
2614
2615 =head1 AUTHOR
2616
2617 Arnar M. Hrafnkelsson (addi@umich.edu) and Tony Cook
2618 (tony@imager.perl.org) See the README for a complete list.
2619
2620 =head1 SEE ALSO
2621
2622 perl(1), Imager::Color(3), Imager::Font(3), Imager::Matrix2d(3),
2623 Affix::Infix2Postfix(3), Parse::RecDescent(3)
2624 http://www.eecs.umich.edu/~addi/perl/Imager/
2625
2626 =cut