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