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