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     return io_new_fd($fd);
 948   }
 949   elsif ($input->{file}) {
 950     my $fh = new IO::File($input->{file},"w+");
 951     unless ($fh) {
 952       $self->_set_error("Could not open file $input->{file}: $!");
 953       return;
 954     }
 955     binmode($fh) or die;
 956     return (io_new_fd(fileno($fh)), $fh);
 957   }
 958   elsif ($input->{data}) {
 959     return io_new_bufchain();
 960   }
 961   elsif ($input->{callback} || $input->{writecb}) {
 962     if ($input->{maxbuffer}) {
 963       return io_new_cb($input->{callback} || $input->{writecb},
 964                        $input->{readcb},
 965                        $input->{seekcb}, $input->{closecb},
 966                        $input->{maxbuffer});
 967     }
 968     else {
 969       return io_new_cb($input->{callback} || $input->{writecb},
 970                        $input->{readcb},
 971                        $input->{seekcb}, $input->{closecb});
 972     }
 973   }
 974   else {
 975     $self->_set_error("file/fd/fh/data/callback parameter missing");
 976     return;
 977   }
 978 }
 979
 980 # Read an image from file
 981
 982 sub read {
 983   my $self = shift;
 984   my %input=@_;
 985
 986   if (defined($self->{IMG})) {
 987     # let IIM_DESTROY do the destruction, since the image may be
 988     # referenced from elsewhere
 989     #i_img_destroy($self->{IMG});
 990     undef($self->{IMG});
 991   }
 992
 993   # FIXME: Find the format here if not specified
 994   # yes the code isn't here yet - next week maybe?
 995   # Next week?  Are you high or something?  That comment
 996   # has been there for half a year dude.
 997   # Look, i just work here, ok?
 998
 999   if (!$input{'type'} and $input{file}) {
1000     $input{'type'}=$FORMATGUESS->($input{file});
1001   }
1002   unless ($input{'type'}) {
1003     $self->_set_error('type parameter missing and not possible to guess from extension');
1004     return undef;
1005   }
1006   if (!$formats{$input{'type'}}) {
1007     $self->{ERRSTR}='format not supported'; return undef;
1008   }
1009
1010   my %iolready=(jpeg=>1, png=>1, tiff=>1, pnm=>1, raw=>1, bmp=>1, tga=>1, rgb=>1, gif=>1);
1011
1012   if ($iolready{$input{'type'}}) {
1013     # Setup data source
1014     my ($IO, $fh) = $self->_get_reader_io(\%input, $input{'type'})
1015       or return;
1016
1017     if ( $input{'type'} eq 'jpeg' ) {
1018       ($self->{IMG},$self->{IPTCRAW})=i_readjpeg_wiol( $IO );
1019       if ( !defined($self->{IMG}) ) {
1020         $self->{ERRSTR}='unable to read jpeg image'; return undef;
1021       }
1022       $self->{DEBUG} && print "loading a jpeg file\n";
1023       return $self;
1024     }
1025
1026     if ( $input{'type'} eq 'tiff' ) {
1027       $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1028       if ( !defined($self->{IMG}) ) {
1029         $self->{ERRSTR}=$self->_error_as_msg(); return undef;
1030       }
1031       $self->{DEBUG} && print "loading a tiff file\n";
1032       return $self;
1033     }
1034
1035     if ( $input{'type'} eq 'pnm' ) {
1036       $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1037       if ( !defined($self->{IMG}) ) {
1038         $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
1039       }
1040       $self->{DEBUG} && print "loading a pnm file\n";
1041       return $self;
1042     }
1043
1044     if ( $input{'type'} eq 'png' ) {
1045       $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1046       if ( !defined($self->{IMG}) ) {
1047         $self->{ERRSTR}='unable to read png image';
1048         return undef;
1049       }
1050       $self->{DEBUG} && print "loading a png file\n";
1051     }
1052
1053     if ( $input{'type'} eq 'bmp' ) {
1054       $self->{IMG}=i_readbmp_wiol( $IO );
1055       if ( !defined($self->{IMG}) ) {
1056         $self->{ERRSTR}=$self->_error_as_msg();
1057         return undef;
1058       }
1059       $self->{DEBUG} && print "loading a bmp file\n";
1060     }
1061
1062     if ( $input{'type'} eq 'gif' ) {
1063       if ($input{colors} && !ref($input{colors})) {
1064         # must be a reference to a scalar that accepts the colour map
1065         $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1066         return undef;
1067       }
1068       if ($input{colors}) {
1069         my $colors;
1070         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1071         if ($colors) {
1072           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1073         }
1074       }
1075       else {
1076         $self->{IMG} =i_readgif_wiol( $IO );
1077       }
1078       if ( !defined($self->{IMG}) ) {
1079         $self->{ERRSTR}=$self->_error_as_msg();
1080         return undef;
1081       }
1082       $self->{DEBUG} && print "loading a gif file\n";
1083     }
1084
1085     if ( $input{'type'} eq 'tga' ) {
1086       $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1087       if ( !defined($self->{IMG}) ) {
1088         $self->{ERRSTR}=$self->_error_as_msg();
1089         return undef;
1090       }
1091       $self->{DEBUG} && print "loading a tga file\n";
1092     }
1093
1094     if ( $input{'type'} eq 'rgb' ) {
1095       $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1096       if ( !defined($self->{IMG}) ) {
1097         $self->{ERRSTR}=$self->_error_as_msg();
1098         return undef;
1099       }
1100       $self->{DEBUG} && print "loading a tga file\n";
1101     }
1102
1103
1104     if ( $input{'type'} eq 'raw' ) {
1105       my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1106
1107       if ( !($params{xsize} && $params{ysize}) ) {
1108         $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1109         return undef;
1110       }
1111
1112       $self->{IMG} = i_readraw_wiol( $IO,
1113                                      $params{xsize},
1114                                      $params{ysize},
1115                                      $params{datachannels},
1116                                      $params{storechannels},
1117                                      $params{interleave});
1118       if ( !defined($self->{IMG}) ) {
1119         $self->{ERRSTR}='unable to read raw image';
1120         return undef;
1121       }
1122       $self->{DEBUG} && print "loading a raw file\n";
1123     }
1124
1125   } else {
1126
1127     # Old code for reference while changing the new stuff
1128
1129     if (!$input{'type'} and $input{file}) {
1130       $input{'type'}=$FORMATGUESS->($input{file});
1131     }
1132
1133     if (!$input{'type'}) {
1134       $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef;
1135     }
1136
1137     if (!$formats{$input{'type'}}) {
1138       $self->{ERRSTR}='format not supported';
1139       return undef;
1140     }
1141
1142     my ($fh, $fd);
1143     if ($input{file}) {
1144       $fh = new IO::File($input{file},"r");
1145       if (!defined $fh) {
1146         $self->{ERRSTR}='Could not open file';
1147         return undef;
1148       }
1149       binmode($fh);
1150       $fd = $fh->fileno();
1151     }
1152
1153     if ($input{fd}) {
1154       $fd=$input{fd};
1155     }
1156
1157     if ( $input{'type'} eq 'gif' ) {
1158       my $colors;
1159       if ($input{colors} && !ref($input{colors})) {
1160         # must be a reference to a scalar that accepts the colour map
1161         $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1162         return undef;
1163       }
1164       if (exists $input{data}) {
1165         if ($input{colors}) {
1166           ($self->{IMG}, $colors) = i_readgif_scalar($input{data});
1167         } else {
1168           $self->{IMG}=i_readgif_scalar($input{data});
1169         }
1170       } else {
1171         if ($input{colors}) {
1172           ($self->{IMG}, $colors) = i_readgif( $fd );
1173         } else {
1174           $self->{IMG} = i_readgif( $fd )
1175         }
1176       }
1177       if ($colors) {
1178         # we may or may not change i_readgif to return blessed objects...
1179         ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1180       }
1181       if ( !defined($self->{IMG}) ) {
1182         $self->{ERRSTR}= 'reading GIF:'._error_as_msg();
1183         return undef;
1184       }
1185       $self->{DEBUG} && print "loading a gif file\n";
1186     }
1187   }
1188   return $self;
1189 }
1190
1191 sub _fix_gif_positions {
1192   my ($opts, $opt, $msg, @imgs) = @_;
1193
1194   my $positions = $opts->{'gif_positions'};
1195   my $index = 0;
1196   for my $pos (@$positions) {
1197     my ($x, $y) = @$pos;
1198     my $img = $imgs[$index++];
1199     $img->settag(gif_left=>$x);
1200     $img->settag(gif_top=>$y) if defined $y;
1201   }
1202   $$msg .= "replaced with the gif_left and gif_top tags";
1203 }
1204
1205 my %obsolete_opts =
1206   (
1207    gif_each_palette=>'gif_local_map',
1208    interlace       => 'gif_interlace',
1209    gif_delays => 'gif_delay',
1210    gif_positions => \&_fix_gif_positions,
1211    gif_loop_count => 'gif_loop',
1212   );
1213
1214 sub _set_opts {
1215   my ($self, $opts, $prefix, @imgs) = @_;
1216
1217   for my $opt (keys %$opts) {
1218     my $tagname = $opt;
1219     if ($obsolete_opts{$opt}) {
1220       my $new = $obsolete_opts{$opt};
1221       my $msg = "Obsolete option $opt ";
1222       if (ref $new) {
1223         $new->($opts, $opt, \$msg, @imgs);
1224       }
1225       else {
1226         $msg .= "replaced with the $new tag ";
1227         $tagname = $new;
1228       }
1229       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1230       warn $msg if $warn_obsolete && $^W;
1231     }
1232     next unless $tagname =~ /^\Q$prefix/;
1233     my $value = $opts->{$opt};
1234     if (ref $value) {
1235       if (UNIVERSAL::isa($value, "Imager::Color")) {
1236         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1237         for my $img (@imgs) {
1238           $img->settag(name=>$tagname, value=>$tag);
1239         }
1240       }
1241       elsif (ref($value) eq 'ARRAY') {
1242         for my $i (0..$#$value) {
1243           my $val = $value->[$i];
1244           if (ref $val) {
1245             if (UNIVERSAL::isa($val, "Imager::Color")) {
1246               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1247               $i < @imgs and
1248                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1249             }
1250             else {
1251               $self->_set_error("Unknown reference type " . ref($value) .
1252                                 " supplied in array for $opt");
1253               return;
1254             }
1255           }
1256           else {
1257             $i < @imgs
1258               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1259           }
1260         }
1261       }
1262       else {
1263         $self->_set_error("Unknown reference type " . ref($value) .
1264                           " supplied for $opt");
1265         return;
1266       }
1267     }
1268     else {
1269       # set it as a tag for every image
1270       for my $img (@imgs) {
1271         $img->settag(name=>$tagname, value=>$value);
1272       }
1273     }
1274   }
1275
1276   return 1;
1277 }
1278
1279 # Write an image to file
1280 sub write {
1281   my $self = shift;
1282   my %input=(jpegquality=>75,
1283              gifquant=>'mc',
1284              lmdither=>6.0,
1285              lmfixed=>[],
1286              idstring=>"",
1287              compress=>1,
1288              wierdpack=>0,
1289              fax_fine=>1, @_);
1290   my $rc;
1291
1292   $self->_set_opts(\%input, "i_", $self)
1293     or return undef;
1294
1295   my %iolready=( tiff=>1, raw=>1, png=>1, pnm=>1, bmp=>1, jpeg=>1, tga=>1,
1296                  gif=>1 ); # this will be SO MUCH BETTER once they are all in there
1297
1298   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1299
1300   if (!$input{'type'} and $input{file}) {
1301     $input{'type'}=$FORMATGUESS->($input{file});
1302   }
1303   if (!$input{'type'}) {
1304     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1305     return undef;
1306   }
1307
1308   if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
1309
1310   my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1311     or return undef;
1312
1313   # this conditional is probably obsolete
1314   if ($iolready{$input{'type'}}) {
1315
1316     if ($input{'type'} eq 'tiff') {
1317       $self->_set_opts(\%input, "tiff_", $self)
1318         or return undef;
1319       $self->_set_opts(\%input, "exif_", $self)
1320         or return undef;
1321
1322       if (defined $input{class} && $input{class} eq 'fax') {
1323         if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1324           $self->{ERRSTR}='Could not write to buffer';
1325           return undef;
1326         }
1327       } else {
1328         if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1329           $self->{ERRSTR}='Could not write to buffer';
1330           return undef;
1331         }
1332       }
1333     } elsif ( $input{'type'} eq 'pnm' ) {
1334       $self->_set_opts(\%input, "pnm_", $self)
1335         or return undef;
1336       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1337         $self->{ERRSTR}='unable to write pnm image';
1338         return undef;
1339       }
1340       $self->{DEBUG} && print "writing a pnm file\n";
1341     } elsif ( $input{'type'} eq 'raw' ) {
1342       $self->_set_opts(\%input, "raw_", $self)
1343         or return undef;
1344       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1345         $self->{ERRSTR}='unable to write raw image';
1346         return undef;
1347       }
1348       $self->{DEBUG} && print "writing a raw file\n";
1349     } elsif ( $input{'type'} eq 'png' ) {
1350       $self->_set_opts(\%input, "png_", $self)
1351         or return undef;
1352       if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1353         $self->{ERRSTR}='unable to write png image';
1354         return undef;
1355       }
1356       $self->{DEBUG} && print "writing a png file\n";
1357     } elsif ( $input{'type'} eq 'jpeg' ) {
1358       $self->_set_opts(\%input, "jpeg_", $self)
1359         or return undef;
1360       $self->_set_opts(\%input, "exif_", $self)
1361         or return undef;
1362       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1363         $self->{ERRSTR} = $self->_error_as_msg();
1364         return undef;
1365       }
1366       $self->{DEBUG} && print "writing a jpeg file\n";
1367     } elsif ( $input{'type'} eq 'bmp' ) {
1368       $self->_set_opts(\%input, "bmp_", $self)
1369         or return undef;
1370       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1371         $self->{ERRSTR}='unable to write bmp image';
1372         return undef;
1373       }
1374       $self->{DEBUG} && print "writing a bmp file\n";
1375     } elsif ( $input{'type'} eq 'tga' ) {
1376       $self->_set_opts(\%input, "tga_", $self)
1377         or return undef;
1378
1379       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1380         $self->{ERRSTR}=$self->_error_as_msg();
1381         return undef;
1382       }
1383       $self->{DEBUG} && print "writing a tga file\n";
1384     } elsif ( $input{'type'} eq 'gif' ) {
1385       $self->_set_opts(\%input, "gif_", $self)
1386         or return undef;
1387       # compatibility with the old interfaces
1388       if ($input{gifquant} eq 'lm') {
1389         $input{make_colors} = 'addi';
1390         $input{translate} = 'perturb';
1391         $input{perturb} = $input{lmdither};
1392       } elsif ($input{gifquant} eq 'gen') {
1393         # just pass options through
1394       } else {
1395         $input{make_colors} = 'webmap'; # ignored
1396         $input{translate} = 'giflib';
1397       }
1398       $rc = i_writegif_wiol($IO, \%input, $self->{IMG});
1399     }
1400
1401     if (exists $input{'data'}) {
1402       my $data = io_slurp($IO);
1403       if (!$data) {
1404         $self->{ERRSTR}='Could not slurp from buffer';
1405         return undef;
1406       }
1407       ${$input{data}} = $data;
1408     }
1409     return $self;
1410   }
1411
1412   return $self;
1413 }
1414
1415 sub write_multi {
1416   my ($class, $opts, @images) = @_;
1417
1418   if (!$opts->{'type'} && $opts->{'file'}) {
1419     $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1420   }
1421   unless ($opts->{'type'}) {
1422     $class->_set_error('type parameter missing and not possible to guess from extension');
1423     return;
1424   }
1425   # translate to ImgRaw
1426   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1427     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1428     return 0;
1429   }
1430   $class->_set_opts($opts, "i_", @images)
1431     or return;
1432   my @work = map $_->{IMG}, @images;
1433   my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1434     or return undef;
1435   if ($opts->{'type'} eq 'gif') {
1436     $class->_set_opts($opts, "gif_", @images)
1437       or return;
1438     my $gif_delays = $opts->{gif_delays};
1439     local $opts->{gif_delays} = $gif_delays;
1440     if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1441       # assume the caller wants the same delay for each frame
1442       $opts->{gif_delays} = [ ($gif_delays) x @images ];
1443     }
1444     my $res = i_writegif_wiol($IO, $opts, @work);
1445     $res or $class->_set_error($class->_error_as_msg());
1446     return $res;
1447   }
1448   elsif ($opts->{'type'} eq 'tiff') {
1449     $class->_set_opts($opts, "tiff_", @images)
1450       or return;
1451     $class->_set_opts($opts, "exif_", @images)
1452       or return;
1453     my $res;
1454     $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1455     if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1456       $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1457     }
1458     else {
1459       $res = i_writetiff_multi_wiol($IO, @work);
1460     }
1461     $res or $class->_set_error($class->_error_as_msg());
1462     return $res;
1463   }
1464   else {
1465     $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
1466     return 0;
1467   }
1468 }
1469
1470 # read multiple images from a file
1471 sub read_multi {
1472   my ($class, %opts) = @_;
1473
1474   if ($opts{file} && !exists $opts{'type'}) {
1475     # guess the type
1476     my $type = $FORMATGUESS->($opts{file});
1477     $opts{'type'} = $type;
1478   }
1479   unless ($opts{'type'}) {
1480     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1481     return;
1482   }
1483
1484   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1485     or return;
1486   if ($opts{'type'} eq 'gif') {
1487     my @imgs;
1488     @imgs = i_readgif_multi_wiol($IO);
1489     if (@imgs) {
1490       return map {
1491         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1492       } @imgs;
1493     }
1494     else {
1495       $ERRSTR = _error_as_msg();
1496       return;
1497     }
1498   }
1499   elsif ($opts{'type'} eq 'tiff') {
1500     my @imgs = i_readtiff_multi_wiol($IO, -1);
1501     if (@imgs) {
1502       return map {
1503         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1504       } @imgs;
1505     }
1506     else {
1507       $ERRSTR = _error_as_msg();
1508       return;
1509     }
1510   }
1511
1512   $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
1513   return;
1514 }
1515
1516 # Destroy an Imager object
1517
1518 sub DESTROY {
1519   my $self=shift;
1520   #    delete $instances{$self};
1521   if (defined($self->{IMG})) {
1522     # the following is now handled by the XS DESTROY method for
1523     # Imager::ImgRaw object
1524     # Re-enabling this will break virtual images
1525     # tested for in t/t020masked.t
1526     # i_img_destroy($self->{IMG});
1527     undef($self->{IMG});
1528   } else {
1529 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1530   }
1531 }
1532
1533 # Perform an inplace filter of an image
1534 # that is the image will be overwritten with the data
1535
1536 sub filter {
1537   my $self=shift;
1538   my %input=@_;
1539   my %hsh;
1540   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1541
1542   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1543
1544   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1545     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1546   }
1547
1548   if ($filters{$input{'type'}}{names}) {
1549     my $names = $filters{$input{'type'}}{names};
1550     for my $name (keys %$names) {
1551       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1552         $input{$name} = $names->{$name}{$input{$name}};
1553       }
1554     }
1555   }
1556   if (defined($filters{$input{'type'}}{defaults})) {
1557     %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
1558   } else {
1559     %hsh=('image',$self->{IMG},%input);
1560   }
1561
1562   my @cs=@{$filters{$input{'type'}}{callseq}};
1563
1564   for(@cs) {
1565     if (!defined($hsh{$_})) {
1566       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1567     }
1568   }
1569
1570   &{$filters{$input{'type'}}{callsub}}(%hsh);
1571
1572   my @b=keys %hsh;
1573
1574   $self->{DEBUG} && print "callseq is: @cs\n";
1575   $self->{DEBUG} && print "matching callseq is: @b\n";
1576
1577   return $self;
1578 }
1579
1580 # Scale an image to requested size and return the scaled version
1581
1582 sub scale {
1583   my $self=shift;
1584   my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
1585   my $img = Imager->new();
1586   my $tmp = Imager->new();
1587
1588   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1589
1590   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
1591     my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
1592     if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1593     if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
1594   } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1595   elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1596
1597   if ($opts{qtype} eq 'normal') {
1598     $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1599     if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1600     $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1601     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1602     return $img;
1603   }
1604   if ($opts{'qtype'} eq 'preview') {
1605     $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
1606     if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1607     return $img;
1608   }
1609   $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1610 }
1611
1612 # Scales only along the X axis
1613
1614 sub scaleX {
1615   my $self=shift;
1616   my %opts=(scalefactor=>0.5,@_);
1617
1618   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1619
1620   my $img = Imager->new();
1621
1622   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1623
1624   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1625   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1626
1627   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1628   return $img;
1629 }
1630
1631 # Scales only along the Y axis
1632
1633 sub scaleY {
1634   my $self=shift;
1635   my %opts=(scalefactor=>0.5,@_);
1636
1637   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1638
1639   my $img = Imager->new();
1640
1641   if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1642
1643   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1644   $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1645
1646   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1647   return $img;
1648 }
1649
1650
1651 # Transform returns a spatial transformation of the input image
1652 # this moves pixels to a new location in the returned image.
1653 # NOTE - should make a utility function to check transforms for
1654 # stack overruns
1655
1656 sub transform {
1657   my $self=shift;
1658   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1659   my %opts=@_;
1660   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1661
1662 #  print Dumper(\%opts);
1663 #  xopcopdes
1664
1665   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1666     if (!$I2P) {
1667       eval ("use Affix::Infix2Postfix;");
1668       print $@;
1669       if ( $@ ) {
1670         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
1671         return undef;
1672       }
1673       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1674                                              {op=>'-',trans=>'Sub'},
1675                                              {op=>'*',trans=>'Mult'},
1676                                              {op=>'/',trans=>'Div'},
1677                                              {op=>'-','type'=>'unary',trans=>'u-'},
1678                                              {op=>'**'},
1679                                              {op=>'func','type'=>'unary'}],
1680                                      'grouping'=>[qw( \( \) )],
1681                                      'func'=>[qw( sin cos )],
1682                                      'vars'=>[qw( x y )]
1683                                     );
1684     }
1685
1686     @xt=$I2P->translate($opts{'xexpr'});
1687     @yt=$I2P->translate($opts{'yexpr'});
1688
1689     $numre=$I2P->{'numre'};
1690     @pt=(0,0);
1691
1692     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1693     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1694     @{$opts{'parm'}}=@pt;
1695   }
1696
1697 #  print Dumper(\%opts);
1698
1699   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1700     $self->{ERRSTR}='transform: no xopcodes given.';
1701     return undef;
1702   }
1703
1704   @op=@{$opts{'xopcodes'}};
1705   for $iop (@op) {
1706     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1707       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1708       return undef;
1709     }
1710     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1711   }
1712
1713
1714 # yopcopdes
1715
1716   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1717     $self->{ERRSTR}='transform: no yopcodes given.';
1718     return undef;
1719   }
1720
1721   @op=@{$opts{'yopcodes'}};
1722   for $iop (@op) {
1723     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1724       $self->{ERRSTR}="transform: illegal opcode '$_'.";
1725       return undef;
1726     }
1727     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1728   }
1729
1730 #parameters
1731
1732   if ( !exists $opts{'parm'}) {
1733     $self->{ERRSTR}='transform: no parameter arg given.';
1734     return undef;
1735   }
1736
1737 #  print Dumper(\@ropx);
1738 #  print Dumper(\@ropy);
1739 #  print Dumper(\@ropy);
1740
1741   my $img = Imager->new();
1742   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1743   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1744   return $img;
1745 }
1746
1747
1748 sub transform2 {
1749   my ($opts, @imgs) = @_;
1750
1751   require "Imager/Expr.pm";
1752
1753   $opts->{variables} = [ qw(x y) ];
1754   my ($width, $height) = @{$opts}{qw(width height)};
1755   if (@imgs) {
1756     $width ||= $imgs[0]->getwidth();
1757     $height ||= $imgs[0]->getheight();
1758     my $img_num = 1;
1759     for my $img (@imgs) {
1760       $opts->{constants}{"w$img_num"} = $img->getwidth();
1761       $opts->{constants}{"h$img_num"} = $img->getheight();
1762       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1763       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1764       ++$img_num;
1765     }
1766   }
1767   if ($width) {
1768     $opts->{constants}{w} = $width;
1769     $opts->{constants}{cx} = $width/2;
1770   }
1771   else {
1772     $Imager::ERRSTR = "No width supplied";
1773     return;
1774   }
1775   if ($height) {
1776     $opts->{constants}{h} = $height;
1777     $opts->{constants}{cy} = $height/2;
1778   }
1779   else {
1780     $Imager::ERRSTR = "No height supplied";
1781     return;
1782   }
1783   my $code = Imager::Expr->new($opts);
1784   if (!$code) {
1785     $Imager::ERRSTR = Imager::Expr::error();
1786     return;
1787   }
1788
1789   my $img = Imager->new();
1790   $img->{IMG} = i_transform2($opts->{width}, $opts->{height}, $code->code(),
1791                              $code->nregs(), $code->cregs(),
1792                              [ map { $_->{IMG} } @imgs ]);
1793   if (!defined $img->{IMG}) {
1794     $Imager::ERRSTR = Imager->_error_as_msg();
1795     return;
1796   }
1797
1798   return $img;
1799 }
1800
1801 sub rubthrough {
1802   my $self=shift;
1803   my %opts=(tx=>0,ty=>0,@_);
1804
1805   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1806   unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1807
1808   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx},$opts{ty})) {
1809     $self->{ERRSTR} = $self->_error_as_msg();
1810     return undef;
1811   }
1812   return $self;
1813 }
1814
1815
1816 sub flip {
1817   my $self  = shift;
1818   my %opts  = @_;
1819   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
1820   my $dir;
1821   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1822   $dir = $xlate{$opts{'dir'}};
1823   return $self if i_flipxy($self->{IMG}, $dir);
1824   return ();
1825 }
1826
1827 sub rotate {
1828   my $self = shift;
1829   my %opts = @_;
1830   if (defined $opts{right}) {
1831     my $degrees = $opts{right};
1832     if ($degrees < 0) {
1833       $degrees += 360 * int(((-$degrees)+360)/360);
1834     }
1835     $degrees = $degrees % 360;
1836     if ($degrees == 0) {
1837       return $self->copy();
1838     }
1839     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1840       my $result = Imager->new();
1841       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1842         return $result;
1843       }
1844       else {
1845         $self->{ERRSTR} = $self->_error_as_msg();
1846         return undef;
1847       }
1848     }
1849     else {
1850       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1851       return undef;
1852     }
1853   }
1854   elsif (defined $opts{radians} || defined $opts{degrees}) {
1855     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1856
1857     my $result = Imager->new;
1858     if ($result->{IMG} = i_rotate_exact($self->{IMG}, $amount)) {
1859       return $result;
1860     }
1861     else {
1862       $self->{ERRSTR} = $self->_error_as_msg();
1863       return undef;
1864     }
1865   }
1866   else {
1867     $self->{ERRSTR} = "Only the 'right' parameter is available";
1868     return undef;
1869   }
1870 }
1871
1872 sub matrix_transform {
1873   my $self = shift;
1874   my %opts = @_;
1875
1876   if ($opts{matrix}) {
1877     my $xsize = $opts{xsize} || $self->getwidth;
1878     my $ysize = $opts{ysize} || $self->getheight;
1879
1880     my $result = Imager->new;
1881     $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1882                                         $opts{matrix})
1883       or return undef;
1884
1885     return $result;
1886   }
1887   else {
1888     $self->{ERRSTR} = "matrix parameter required";
1889     return undef;
1890   }
1891 }
1892
1893 # blame Leolo :)
1894 *yatf = \&matrix_transform;
1895
1896 # These two are supported for legacy code only
1897
1898 sub i_color_new {
1899   return Imager::Color->new(@_);
1900 }
1901
1902 sub i_color_set {
1903   return Imager::Color::set(@_);
1904 }
1905
1906 # Draws a box between the specified corner points.
1907 sub box {
1908   my $self=shift;
1909   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1910   my $dflcl=i_color_new(255,255,255,255);
1911   my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1912
1913   if (exists $opts{'box'}) {
1914     $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1915     $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1916     $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1917     $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1918   }
1919
1920   if ($opts{filled}) {
1921     my $color = _color($opts{'color'});
1922     unless ($color) {
1923       $self->{ERRSTR} = $Imager::ERRSTR;
1924       return;
1925     }
1926     i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1927                  $opts{ymax}, $color);
1928   }
1929   elsif ($opts{fill}) {
1930     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1931       # assume it's a hash ref
1932       require 'Imager/Fill.pm';
1933       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1934         $self->{ERRSTR} = $Imager::ERRSTR;
1935         return undef;
1936       }
1937     }
1938     i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1939                 $opts{ymax},$opts{fill}{fill});
1940   }
1941   else {
1942     my $color = _color($opts{'color'});
1943     unless ($color) {
1944       $self->{ERRSTR} = $Imager::ERRSTR;
1945       return;
1946     }
1947     i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
1948           $color);
1949   }
1950   return $self;
1951 }
1952
1953 # Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
1954
1955 sub arc {
1956   my $self=shift;
1957   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1958   my $dflcl=i_color_new(255,255,255,255);
1959   my %opts=(color=>$dflcl,
1960             'r'=>min($self->getwidth(),$self->getheight())/3,
1961             'x'=>$self->getwidth()/2,
1962             'y'=>$self->getheight()/2,
1963             'd1'=>0, 'd2'=>361, @_);
1964   if ($opts{fill}) {
1965     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1966       # assume it's a hash ref
1967       require 'Imager/Fill.pm';
1968       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1969         $self->{ERRSTR} = $Imager::ERRSTR;
1970         return;
1971       }
1972     }
1973     i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
1974                 $opts{'d2'}, $opts{fill}{fill});
1975   }
1976   else {
1977     my $color = _color($opts{'color'});
1978     unless ($color) {
1979       $self->{ERRSTR} = $Imager::ERRSTR;
1980       return;
1981     }
1982     if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
1983       i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
1984                   $color);
1985     }
1986     else {
1987       if ($opts{'d1'} <= $opts{'d2'}) {
1988         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1989               $opts{'d1'}, $opts{'d2'}, $color);
1990       }
1991       else {
1992         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1993               $opts{'d1'}, 361,         $color);
1994         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
1995               0,           $opts{'d2'}, $color);
1996       }
1997     }
1998   }
1999
2000   return $self;
2001 }
2002
2003 # Draws a line from one point to (but not including) the destination point
2004
2005 sub line {
2006   my $self=shift;
2007   my $dflcl=i_color_new(0,0,0,0);
2008   my %opts=(color=>$dflcl,@_);
2009   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2010
2011   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2012   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2013
2014   my $color = _color($opts{'color'});
2015   unless ($color) {
2016     $self->{ERRSTR} = $Imager::ERRSTR;
2017     return;
2018   }
2019   $opts{antialias} = $opts{aa} if defined $opts{aa};
2020   if ($opts{antialias}) {
2021     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2022               $color);
2023   } else {
2024     i_draw($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2025            $color);
2026   }
2027   return $self;
2028 }
2029
2030 # Draws a line between an ordered set of points - It more or less just transforms this
2031 # into a list of lines.
2032
2033 sub polyline {
2034   my $self=shift;
2035   my ($pt,$ls,@points);
2036   my $dflcl=i_color_new(0,0,0,0);
2037   my %opts=(color=>$dflcl,@_);
2038
2039   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2040
2041   if (exists($opts{points})) { @points=@{$opts{points}}; }
2042   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2043     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2044     }
2045
2046 #  print Dumper(\@points);
2047
2048   my $color = _color($opts{'color'});
2049   unless ($color) {
2050     $self->{ERRSTR} = $Imager::ERRSTR;
2051     return;
2052   }
2053   $opts{antialias} = $opts{aa} if defined $opts{aa};
2054   if ($opts{antialias}) {
2055     for $pt(@points) {
2056       if (defined($ls)) {
2057         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
2058       }
2059       $ls=$pt;
2060     }
2061   } else {
2062     for $pt(@points) {
2063       if (defined($ls)) {
2064         i_draw($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
2065       }
2066       $ls=$pt;
2067     }
2068   }
2069   return $self;
2070 }
2071
2072 sub polygon {
2073   my $self = shift;
2074   my ($pt,$ls,@points);
2075   my $dflcl = i_color_new(0,0,0,0);
2076   my %opts = (color=>$dflcl, @_);
2077
2078   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2079
2080   if (exists($opts{points})) {
2081     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2082     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2083   }
2084
2085   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2086     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2087   }
2088
2089   if ($opts{'fill'}) {
2090     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2091       # assume it's a hash ref
2092       require 'Imager/Fill.pm';
2093       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2094         $self->{ERRSTR} = $Imager::ERRSTR;
2095         return undef;
2096       }
2097     }
2098     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2099                     $opts{'fill'}{'fill'});
2100   }
2101   else {
2102     my $color = _color($opts{'color'});
2103     unless ($color) {
2104       $self->{ERRSTR} = $Imager::ERRSTR;
2105       return;
2106     }
2107     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2108   }
2109
2110   return $self;
2111 }
2112
2113
2114 # this the multipoint bezier curve
2115 # this is here more for testing that actual usage since
2116 # this is not a good algorithm.  Usually the curve would be
2117 # broken into smaller segments and each done individually.
2118
2119 sub polybezier {
2120   my $self=shift;
2121   my ($pt,$ls,@points);
2122   my $dflcl=i_color_new(0,0,0,0);
2123   my %opts=(color=>$dflcl,@_);
2124
2125   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2126
2127   if (exists $opts{points}) {
2128     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2129     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2130   }
2131
2132   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2133     $self->{ERRSTR}='Missing or invalid points.';
2134     return;
2135   }
2136
2137   my $color = _color($opts{'color'});
2138   unless ($color) {
2139     $self->{ERRSTR} = $Imager::ERRSTR;
2140     return;
2141   }
2142   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2143   return $self;
2144 }
2145
2146 sub flood_fill {
2147   my $self = shift;
2148   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2149
2150   unless (exists $opts{'x'} && exists $opts{'y'}) {
2151     $self->{ERRSTR} = "missing seed x and y parameters";
2152     return undef;
2153   }
2154
2155   if ($opts{fill}) {
2156     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2157       # assume it's a hash ref
2158       require 'Imager/Fill.pm';
2159       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2160         $self->{ERRSTR} = $Imager::ERRSTR;
2161         return;
2162       }
2163     }
2164     i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
2165   }
2166   else {
2167     my $color = _color($opts{'color'});
2168     unless ($color) {
2169       $self->{ERRSTR} = $Imager::ERRSTR;
2170       return;
2171     }
2172     i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2173   }
2174
2175   $self;
2176 }
2177
2178 sub setpixel {
2179   my $self = shift;
2180
2181   my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2182
2183   unless (exists $opts{'x'} && exists $opts{'y'}) {
2184     $self->{ERRSTR} = 'missing x and y parameters';
2185     return undef;
2186   }
2187
2188   my $x = $opts{'x'};
2189   my $y = $opts{'y'};
2190   my $color = _color($opts{color})
2191     or return undef;
2192   if (ref $x && ref $y) {
2193     unless (@$x == @$y) {
2194       $self->{ERRSTR} = 'length of x and y mistmatch';
2195       return undef;
2196     }
2197     if ($color->isa('Imager::Color')) {
2198       for my $i (0..$#{$opts{'x'}}) {
2199         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2200       }
2201     }
2202     else {
2203       for my $i (0..$#{$opts{'x'}}) {
2204         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2205       }
2206     }
2207   }
2208   else {
2209     if ($color->isa('Imager::Color')) {
2210       i_ppix($self->{IMG}, $x, $y, $color);
2211     }
2212     else {
2213       i_ppixf($self->{IMG}, $x, $y, $color);
2214     }
2215   }
2216
2217   $self;
2218 }
2219
2220 sub getpixel {
2221   my $self = shift;
2222
2223   my %opts = ( type=>'8bit', @_);
2224
2225   unless (exists $opts{'x'} && exists $opts{'y'}) {
2226     $self->{ERRSTR} = 'missing x and y parameters';
2227     return undef;
2228   }
2229
2230   my $x = $opts{'x'};
2231   my $y = $opts{'y'};
2232   if (ref $x && ref $y) {
2233     unless (@$x == @$y) {
2234       $self->{ERRSTR} = 'length of x and y mismatch';
2235       return undef;
2236     }
2237     my @result;
2238     if ($opts{type} eq '8bit') {
2239       for my $i (0..$#{$opts{'x'}}) {
2240         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2241       }
2242     }
2243     else {
2244       for my $i (0..$#{$opts{'x'}}) {
2245         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2246       }
2247     }
2248     return wantarray ? @result : \@result;
2249   }
2250   else {
2251     if ($opts{type} eq '8bit') {
2252       return i_get_pixel($self->{IMG}, $x, $y);
2253     }
2254     else {
2255       return i_gpixf($self->{IMG}, $x, $y);
2256     }
2257   }
2258
2259   $self;
2260 }
2261
2262 # make an identity matrix of the given size
2263 sub _identity {
2264   my ($size) = @_;
2265
2266   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2267   for my $c (0 .. ($size-1)) {
2268     $matrix->[$c][$c] = 1;
2269   }
2270   return $matrix;
2271 }
2272
2273 # general function to convert an image
2274 sub convert {
2275   my ($self, %opts) = @_;
2276   my $matrix;
2277
2278   # the user can either specify a matrix or preset
2279   # the matrix overrides the preset
2280   if (!exists($opts{matrix})) {
2281     unless (exists($opts{preset})) {
2282       $self->{ERRSTR} = "convert() needs a matrix or preset";
2283       return;
2284     }
2285     else {
2286       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2287         # convert to greyscale, keeping the alpha channel if any
2288         if ($self->getchannels == 3) {
2289           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2290         }
2291         elsif ($self->getchannels == 4) {
2292           # preserve the alpha channel
2293           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2294                       [ 0,     0,     0,     1 ] ];
2295         }
2296         else {
2297           # an identity
2298           $matrix = _identity($self->getchannels);
2299         }
2300       }
2301       elsif ($opts{preset} eq 'noalpha') {
2302         # strip the alpha channel
2303         if ($self->getchannels == 2 or $self->getchannels == 4) {
2304           $matrix = _identity($self->getchannels);
2305           pop(@$matrix); # lose the alpha entry
2306         }
2307         else {
2308           $matrix = _identity($self->getchannels);
2309         }
2310       }
2311       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2312         # extract channel 0
2313         $matrix = [ [ 1 ] ];
2314       }
2315       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2316         $matrix = [ [ 0, 1 ] ];
2317       }
2318       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2319         $matrix = [ [ 0, 0, 1 ] ];
2320       }
2321       elsif ($opts{preset} eq 'alpha') {
2322         if ($self->getchannels == 2 or $self->getchannels == 4) {
2323           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2324         }
2325         else {
2326           # the alpha is just 1 <shrug>
2327           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2328         }
2329       }
2330       elsif ($opts{preset} eq 'rgb') {
2331         if ($self->getchannels == 1) {
2332           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2333         }
2334         elsif ($self->getchannels == 2) {
2335           # preserve the alpha channel
2336           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2337         }
2338         else {
2339           $matrix = _identity($self->getchannels);
2340         }
2341       }
2342       elsif ($opts{preset} eq 'addalpha') {
2343         if ($self->getchannels == 1) {
2344           $matrix = _identity(2);
2345         }
2346         elsif ($self->getchannels == 3) {
2347           $matrix = _identity(4);
2348         }
2349         else {
2350           $matrix = _identity($self->getchannels);
2351         }
2352       }
2353       else {
2354         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2355         return undef;
2356       }
2357     }
2358   }
2359   else {
2360     $matrix = $opts{matrix};
2361   }
2362
2363   my $new = Imager->new();
2364   $new->{IMG} = i_img_new();
2365   unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2366     # most likely a bad matrix
2367     $self->{ERRSTR} = _error_as_msg();
2368     return undef;
2369   }
2370   return $new;
2371 }
2372
2373
2374 # general function to map an image through lookup tables
2375
2376 sub map {
2377   my ($self, %opts) = @_;
2378   my @chlist = qw( red green blue alpha );
2379
2380   if (!exists($opts{'maps'})) {
2381     # make maps from channel maps
2382     my $chnum;
2383     for $chnum (0..$#chlist) {
2384       if (exists $opts{$chlist[$chnum]}) {
2385         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2386       } elsif (exists $opts{'all'}) {
2387         $opts{'maps'}[$chnum] = $opts{'all'};
2388       }
2389     }
2390   }
2391   if ($opts{'maps'} and $self->{IMG}) {
2392     i_map($self->{IMG}, $opts{'maps'} );
2393   }
2394   return $self;
2395 }
2396
2397 # destructive border - image is shrunk by one pixel all around
2398
2399 sub border {
2400   my ($self,%opts)=@_;
2401   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2402   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2403 }
2404
2405
2406 # Get the width of an image
2407
2408 sub getwidth {
2409   my $self = shift;
2410   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2411   return (i_img_info($self->{IMG}))[0];
2412 }
2413
2414 # Get the height of an image
2415
2416 sub getheight {
2417   my $self = shift;
2418   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2419   return (i_img_info($self->{IMG}))[1];
2420 }
2421
2422 # Get number of channels in an image
2423
2424 sub getchannels {
2425   my $self = shift;
2426   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2427   return i_img_getchannels($self->{IMG});
2428 }
2429
2430 # Get channel mask
2431
2432 sub getmask {
2433   my $self = shift;
2434   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2435   return i_img_getmask($self->{IMG});
2436 }
2437
2438 # Set channel mask
2439
2440 sub setmask {
2441   my $self = shift;
2442   my %opts = @_;
2443   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2444   i_img_setmask( $self->{IMG} , $opts{mask} );
2445 }
2446
2447 # Get number of colors in an image
2448
2449 sub getcolorcount {
2450   my $self=shift;
2451   my %opts=('maxcolors'=>2**30,@_);
2452   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2453   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2454   return ($rc==-1? undef : $rc);
2455 }
2456
2457 # draw string to an image
2458
2459 sub string {
2460   my $self = shift;
2461   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2462
2463   my %input=('x'=>0, 'y'=>0, @_);
2464   $input{string}||=$input{text};
2465
2466   unless(exists $input{string}) {
2467     $self->{ERRSTR}="missing required parameter 'string'";
2468     return;
2469   }
2470
2471   unless($input{font}) {
2472     $self->{ERRSTR}="missing required parameter 'font'";
2473     return;
2474   }
2475
2476   unless ($input{font}->draw(image=>$self, %input)) {
2477     $self->{ERRSTR} = $self->_error_as_msg();
2478     return;
2479   }
2480
2481   return $self;
2482 }
2483
2484 # Shortcuts that can be exported
2485
2486 sub newcolor { Imager::Color->new(@_); }
2487 sub newfont  { Imager::Font->new(@_); }
2488
2489 *NC=*newcolour=*newcolor;
2490 *NF=*newfont;
2491
2492 *open=\&read;
2493 *circle=\&arc;
2494
2495
2496 #### Utility routines
2497
2498 sub errstr {
2499   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2500 }
2501
2502 sub _set_error {
2503   my ($self, $msg) = @_;
2504
2505   if (ref $self) {
2506     $self->{ERRSTR} = $msg;
2507   }
2508   else {
2509     $ERRSTR = $msg;
2510   }
2511 }
2512
2513 # Default guess for the type of an image from extension
2514
2515 sub def_guess_type {
2516   my $name=lc(shift);
2517   my $ext;
2518   $ext=($name =~ m/\.([^\.]+)$/)[0];
2519   return 'tiff' if ($ext =~ m/^tiff?$/);
2520   return 'jpeg' if ($ext =~ m/^jpe?g$/);
2521   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
2522   return 'png'  if ($ext eq "png");
2523   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
2524   return 'tga'  if ($ext eq "tga");
2525   return 'rgb'  if ($ext eq "rgb");
2526   return 'gif'  if ($ext eq "gif");
2527   return 'raw'  if ($ext eq "raw");
2528   return ();
2529 }
2530
2531 # get the minimum of a list
2532
2533 sub min {
2534   my $mx=shift;
2535   for(@_) { if ($_<$mx) { $mx=$_; }}
2536   return $mx;
2537 }
2538
2539 # get the maximum of a list
2540
2541 sub max {
2542   my $mx=shift;
2543   for(@_) { if ($_>$mx) { $mx=$_; }}
2544   return $mx;
2545 }
2546
2547 # string stuff for iptc headers
2548
2549 sub clean {
2550   my($str)=$_[0];
2551   $str = substr($str,3);
2552   $str =~ s/[\n\r]//g;
2553   $str =~ s/\s+/ /g;
2554   $str =~ s/^\s//;
2555   $str =~ s/\s$//;
2556   return $str;
2557 }
2558
2559 # A little hack to parse iptc headers.
2560
2561 sub parseiptc {
2562   my $self=shift;
2563   my(@sar,$item,@ar);
2564   my($caption,$photogr,$headln,$credit);
2565
2566   my $str=$self->{IPTCRAW};
2567
2568   #print $str;
2569
2570   @ar=split(/8BIM/,$str);
2571
2572   my $i=0;
2573   foreach (@ar) {
2574     if (/^\004\004/) {
2575       @sar=split(/\034\002/);
2576       foreach $item (@sar) {
2577         if ($item =~ m/^x/) {
2578           $caption=&clean($item);
2579           $i++;
2580         }
2581         if ($item =~ m/^P/) {
2582           $photogr=&clean($item);
2583           $i++;
2584         }
2585         if ($item =~ m/^i/) {
2586           $headln=&clean($item);
2587           $i++;
2588         }
2589         if ($item =~ m/^n/) {
2590           $credit=&clean($item);
2591           $i++;
2592         }
2593       }
2594     }
2595   }
2596   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2597 }
2598
2599 # Autoload methods go after =cut, and are processed by the autosplit program.
2600
2601 1;
2602 __END__
2603 # Below is the stub of documentation for your module. You better edit it!
2604
2605 =head1 NAME
2606
2607 Imager - Perl extension for Generating 24 bit Images
2608
2609 =head1 SYNOPSIS
2610
2611   # Thumbnail example
2612
2613   #!/usr/bin/perl -w
2614   use strict;
2615   use Imager;
2616
2617   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2618   my $file = shift;
2619
2620   my $format;
2621
2622   my $img = Imager->new();
2623   $img->open(file=>$file) or die $img->errstr();
2624
2625   $file =~ s/\.[^.]*$//;
2626
2627   # Create smaller version
2628   my $thumb = $img->scale(scalefactor=>.3);
2629
2630   # Autostretch individual channels
2631   $thumb->filter(type=>'autolevels');
2632
2633   # try to save in one of these formats
2634   SAVE:
2635
2636   for $format ( qw( png gif jpg tiff ppm ) ) {
2637     # Check if given format is supported
2638     if ($Imager::formats{$format}) {
2639       $file.="_low.$format";
2640       print "Storing image as: $file\n";
2641       $thumb->write(file=>$file) or
2642         die $thumb->errstr;
2643       last SAVE;
2644     }
2645   }
2646
2647
2648   # Logo Generator Example
2649
2650
2651
2652 =head1 DESCRIPTION
2653
2654 Imager is a module for creating and altering images.  It can read and
2655 write various image formats, draw primitive shapes like lines,and
2656 polygons, blend multiple images together in various ways, scale, crop,
2657 render text and more.
2658
2659 =head2 Overview of documentation
2660
2661 =over
2662
2663 =item Imager
2664
2665 This document - Synopsis Example, Table of Contents and Overview.
2666
2667 =item Imager::ImageTypes
2668
2669 Direct type/virtual images, RGB(A)/paletted images, 8/16/double
2670 bits/channel, color maps, channel masks, image tags, color
2671 quantization.
2672
2673 =item Imager::Files
2674
2675 IO interaction, reading/writing images, format specific tags.
2676
2677 =item Imager::Draw
2678
2679 Drawing Primitives, lines, boxes, circles, arcs, flood fill.
2680
2681 =item Imager::Color
2682
2683 Color specification.
2684
2685 =item Imager::Fill
2686
2687 Fill pattern specification.
2688
2689 =item Imager::Font
2690
2691 General font rendering, bounding boxes and font metrics.
2692
2693 =item Imager::Transformations
2694
2695 Copying, scaling, cropping, flipping, blending, pasting, convert and
2696 map.
2697
2698 =item Imager::Engines
2699
2700 Programmable transformations through C<transform()>, C<transform2()>
2701 and C<matrix_transform()>.
2702
2703 =item Imager::Filters
2704
2705 Filters, sharpen, blur, noise, convolve etc. and filter plugins.
2706
2707 =item Imager::Expr
2708
2709 Expressions for evaluation engine used by transform2().
2710
2711 =item Imager::Matrix2d
2712
2713 Helper class for affine transformations.
2714
2715 =item Imager::Fountain
2716
2717 Helper for making gradient profiles.
2718
2719 =back
2720
2721
2722
2723 =head2 Basic Overview
2724
2725 An Image object is created with C<$img = Imager-E<gt>new()> Should
2726 this fail for some reason an explanation can be found in
2727 C<$Imager::ERRSTR> usually error messages are stored in
2728 C<$img-E<gt>{ERRSTR}>, but since no object is created this is the only
2729 way to give back errors.  C<$Imager::ERRSTR> is also used to report
2730 all errors not directly associated with an image object. Examples:
2731
2732   $img=Imager->new(); # This is an empty image (size is 0 by 0)
2733   $img->open(file=>'lena.png',type=>'png'); # initializes from file
2734
2735 or if you want to create an empty image:
2736
2737   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2738
2739 This example creates a completely black image of width 400 and height
2740 300 and 4 channels.
2741
2742 =head1 SUPPORT
2743
2744 You can ask for help, report bugs or express your undying love for
2745 Imager on the Imager-devel mailing list.
2746
2747 To subscribe send a message with C<subscribe> in the body to:
2748
2749    imager-devel+request@molar.is
2750
2751 or use the form at:
2752
2753    http://www.molar.is/en/lists/imager-devel/
2754
2755 where you can also find the mailing list archive.
2756
2757 If you're into IRC, you can typically find the developers in #Imager
2758 on irc.rhizomatic.net.  As with any IRC channel, the participants
2759 could be occupied or asleep, so please be patient.
2760
2761 =head1 BUGS
2762
2763 Bugs are listed individually for relevant pod pages.
2764
2765 =head1 AUTHOR
2766
2767 Arnar M. Hrafnkelsson (addi@umich.edu) and Tony Cook
2768 (tony@imager.perl.org) See the README for a complete list.
2769
2770 =head1 SEE ALSO
2771
2772 perl(1), Imager::Color(3), Imager::Font(3), Imager::Matrix2d(3),
2773
2774 Affix::Infix2Postfix(3), Parse::RecDescent(3)
2775 http://www.eecs.umich.edu/~addi/perl/Imager/
2776
2777 =cut