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