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