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 %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_tt_set_aa
  65                 i_tt_cp
  66                 i_tt_text
  67                 i_tt_bbox
  68
  69                 i_readpnm_wiol
  70                 i_writeppm_wiol
  71
  72                 i_readraw_wiol
  73                 i_writeraw_wiol
  74
  75                 i_contrast
  76                 i_hardinvert
  77                 i_noise
  78                 i_bumpmap
  79                 i_postlevels
  80                 i_mosaic
  81                 i_watermark
  82
  83                 malloc_state
  84
  85                 list_formats
  86
  87                 i_gifquant
  88
  89                 newfont
  90                 newcolor
  91                 newcolour
  92                 NC
  93                 NF
  94                 NCF
  95 );
  96
  97 @EXPORT=qw(
  98            init_log
  99            i_list_formats
 100            i_has_format
 101            malloc_state
 102            i_color_new
 103
 104            i_img_empty
 105            i_img_empty_ch
 106           );
 107
 108 %EXPORT_TAGS=
 109   (handy => [qw(
 110                 newfont
 111                 newcolor
 112                 NF
 113                 NC
 114                 NCF
 115                )],
 116    all => [@EXPORT_OK],
 117    default => [qw(
 118                   load_plugin
 119                   unload_plugin
 120                  )]);
 121
 122 # registered file readers
 123 my %readers;
 124
 125 # registered file writers
 126 my %writers;
 127
 128 # modules we attempted to autoload
 129 my %attempted_to_load;
 130
 131 # library keys that are image file formats
 132 my %file_formats = map { $_ => 1 } qw/tiff pnm gif png jpeg raw bmp tga/;
 133
 134 # image pixel combine types
 135 my @combine_types =
 136   qw/none normal multiply dissolve add subtract diff lighten darken
 137      hue saturation value color/;
 138 my %combine_types;
 139 @combine_types{@combine_types} = 0 .. $#combine_types;
 140 $combine_types{mult} = $combine_types{multiply};
 141 $combine_types{'sub'}  = $combine_types{subtract};
 142 $combine_types{sat}  = $combine_types{saturation};
 143
 144 # this will be used to store global defaults at some point
 145 my %defaults;
 146
 147 BEGIN {
 148   require Exporter;
 149   @ISA = qw(Exporter);
 150   $VERSION = '0.80_01';
 151   eval {
 152     require XSLoader;
 153     XSLoader::load(Imager => $VERSION);
 154     1;
 155   } or do {
 156     require DynaLoader;
 157     push @ISA, 'DynaLoader';
 158     bootstrap Imager $VERSION;
 159   }
 160 }
 161
 162 my %formats_low;
 163 my %format_classes =
 164   (
 165    png => "Imager::File::PNG",
 166    gif => "Imager::File::GIF",
 167    tiff => "Imager::File::TIFF",
 168    jpeg => "Imager::File::JPEG",
 169    w32 => "Imager::Font::W32",
 170    ft2 => "Imager::Font::FT2",
 171    t1 => "Imager::Font::T1",
 172   );
 173
 174 tie %formats, "Imager::FORMATS", \%formats_low, \%format_classes;
 175
 176 BEGIN {
 177   for(i_list_formats()) { $formats_low{$_}++; }
 178
 179   %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
 180
 181   $DEBUG=0;
 182
 183   # the members of the subhashes under %filters are:
 184   #  callseq - a list of the parameters to the underlying filter in the
 185   #            order they are passed
 186   #  callsub - a code ref that takes a named parameter list and calls the
 187   #            underlying filter
 188   #  defaults - a hash of default values
 189   #  names - defines names for value of given parameters so if the names
 190   #          field is foo=> { bar=>1 }, and the user supplies "bar" as the
 191   #          foo parameter, the filter will receive 1 for the foo
 192   #          parameter
 193   $filters{contrast}={
 194                       callseq => ['image','intensity'],
 195                       callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
 196                      };
 197
 198   $filters{noise} ={
 199                     callseq => ['image', 'amount', 'subtype'],
 200                     defaults => { amount=>3,subtype=>0 },
 201                     callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
 202                    };
 203
 204   $filters{hardinvert} ={
 205                          callseq => ['image'],
 206                          defaults => { },
 207                          callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
 208                         };
 209
 210   $filters{hardinvertall} =
 211     {
 212      callseq => ['image'],
 213      defaults => { },
 214      callsub => sub { my %hsh=@_; i_hardinvertall($hsh{image}); }
 215     };
 216
 217   $filters{autolevels} ={
 218                          callseq => ['image','lsat','usat','skew'],
 219                          defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
 220                          callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
 221                         };
 222
 223   $filters{turbnoise} ={
 224                         callseq => ['image'],
 225                         defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
 226                         callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
 227                        };
 228
 229   $filters{radnoise} ={
 230                        callseq => ['image'],
 231                        defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
 232                        callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
 233                       };
 234
 235   $filters{conv} =
 236     {
 237      callseq => ['image', 'coef'],
 238      defaults => { },
 239      callsub =>
 240      sub {
 241        my %hsh=@_;
 242        i_conv($hsh{image},$hsh{coef})
 243          or die Imager->_error_as_msg() . "\n";
 244      }
 245     };
 246
 247   $filters{gradgen} =
 248     {
 249      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 250      defaults => { dist => 0 },
 251      callsub =>
 252      sub {
 253        my %hsh=@_;
 254        my @colors = @{$hsh{colors}};
 255        $_ = _color($_)
 256          for @colors;
 257        i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
 258      }
 259     };
 260
 261   $filters{nearest_color} =
 262     {
 263      callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
 264      defaults => { },
 265      callsub =>
 266      sub {
 267        my %hsh=@_;
 268        # make sure the segments are specified with colors
 269        my @colors;
 270        for my $color (@{$hsh{colors}}) {
 271          my $new_color = _color($color)
 272            or die $Imager::ERRSTR."\n";
 273          push @colors, $new_color;
 274        }
 275
 276        i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors,
 277                        $hsh{dist})
 278          or die Imager->_error_as_msg() . "\n";
 279      },
 280     };
 281   $filters{gaussian} = {
 282                         callseq => [ 'image', 'stddev' ],
 283                         defaults => { },
 284                         callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
 285                        };
 286   $filters{mosaic} =
 287     {
 288      callseq => [ qw(image size) ],
 289      defaults => { size => 20 },
 290      callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
 291     };
 292   $filters{bumpmap} =
 293     {
 294      callseq => [ qw(image bump elevation lightx lighty st) ],
 295      defaults => { elevation=>0, st=> 2 },
 296      callsub => sub {
 297        my %hsh = @_;
 298        i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
 299                  $hsh{lightx}, $hsh{lighty}, $hsh{st});
 300      },
 301     };
 302   $filters{bumpmap_complex} =
 303     {
 304      callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
 305      defaults => {
 306                   channel => 0,
 307                   tx => 0,
 308                   ty => 0,
 309                   Lx => 0.2,
 310                   Ly => 0.4,
 311                   Lz => -1.0,
 312                   cd => 1.0,
 313                   cs => 40,
 314                   n => 1.3,
 315                   Ia => [0,0,0],
 316                   Il => [255,255,255],
 317                   Is => [255,255,255],
 318                  },
 319      callsub => sub {
 320        my %hsh = @_;
 321        for my $cname (qw/Ia Il Is/) {
 322          my $old = $hsh{$cname};
 323          my $new_color = _color($old)
 324            or die $Imager::ERRSTR, "\n";
 325          $hsh{$cname} = $new_color;
 326        }
 327        i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
 328                  $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
 329                  $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
 330                  $hsh{Is});
 331      },
 332     };
 333   $filters{postlevels} =
 334     {
 335      callseq  => [ qw(image levels) ],
 336      defaults => { levels => 10 },
 337      callsub  => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
 338     };
 339   $filters{watermark} =
 340     {
 341      callseq  => [ qw(image wmark tx ty pixdiff) ],
 342      defaults => { pixdiff=>10, tx=>0, ty=>0 },
 343      callsub  =>
 344      sub {
 345        my %hsh = @_;
 346        i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
 347                    $hsh{pixdiff});
 348      },
 349     };
 350   $filters{fountain} =
 351     {
 352      callseq  => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
 353      names    => {
 354                   ftype => { linear         => 0,
 355                              bilinear       => 1,
 356                              radial         => 2,
 357                              radial_square  => 3,
 358                              revolution     => 4,
 359                              conical        => 5 },
 360                   repeat => { none      => 0,
 361                               sawtooth  => 1,
 362                               triangle  => 2,
 363                               saw_both  => 3,
 364                               tri_both  => 4,
 365                             },
 366                   super_sample => {
 367                                    none    => 0,
 368                                    grid    => 1,
 369                                    random  => 2,
 370                                    circle  => 3,
 371                                   },
 372                   combine => {
 373                               none      => 0,
 374                               normal    => 1,
 375                               multiply  => 2, mult => 2,
 376                               dissolve  => 3,
 377                               add       => 4,
 378                               subtract  => 5, 'sub' => 5,
 379                               diff      => 6,
 380                               lighten   => 7,
 381                               darken    => 8,
 382                               hue       => 9,
 383                               sat       => 10,
 384                               value     => 11,
 385                               color     => 12,
 386                              },
 387                  },
 388      defaults => { ftype => 0, repeat => 0, combine => 0,
 389                    super_sample => 0, ssample_param => 4,
 390                    segments=>[
 391                               [ 0, 0.5, 1,
 392                                 [0,0,0],
 393                                 [255, 255, 255],
 394                                 0, 0,
 395                               ],
 396                              ],
 397                  },
 398      callsub  =>
 399      sub {
 400        my %hsh = @_;
 401
 402        # make sure the segments are specified with colors
 403        my @segments;
 404        for my $segment (@{$hsh{segments}}) {
 405          my @new_segment = @$segment;
 406
 407          $_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
 408          push @segments, \@new_segment;
 409        }
 410
 411        i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
 412                   $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
 413                   $hsh{ssample_param}, \@segments)
 414          or die Imager->_error_as_msg() . "\n";
 415      },
 416     };
 417   $filters{unsharpmask} =
 418     {
 419      callseq => [ qw(image stddev scale) ],
 420      defaults => { stddev=>2.0, scale=>1.0 },
 421      callsub =>
 422      sub {
 423        my %hsh = @_;
 424        i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
 425      },
 426     };
 427
 428   $FORMATGUESS=\&def_guess_type;
 429
 430   $warn_obsolete = 1;
 431 }
 432
 433 #
 434 # Non methods
 435 #
 436
 437 # initlize Imager
 438 # NOTE: this might be moved to an import override later on
 439
 440 sub import {
 441   my $i = 1;
 442   while ($i < @_) {
 443     if ($_[$i] eq '-log-stderr') {
 444       init_log(undef, 4);
 445       splice(@_, $i, 1);
 446     }
 447     else {
 448       ++$i;
 449     }
 450   }
 451   goto &Exporter::import;
 452 }
 453
 454 sub init_log {
 455   i_init_log($_[0],$_[1]);
 456   i_log_entry("Imager $VERSION starting\n", 1);
 457 }
 458
 459
 460 sub init {
 461   my %parms=(loglevel=>1,@_);
 462   if ($parms{'log'}) {
 463     init_log($parms{'log'},$parms{'loglevel'});
 464   }
 465
 466   if (exists $parms{'warn_obsolete'}) {
 467     $warn_obsolete = $parms{'warn_obsolete'};
 468   }
 469
 470   if (exists $parms{'t1log'}) {
 471     if ($formats{t1}) {
 472       Imager::Font::T1::i_init_t1($parms{'t1log'});
 473     }
 474   }
 475 }
 476
 477 END {
 478   if ($DEBUG) {
 479     print "shutdown code\n";
 480     #   for(keys %instances) { $instances{$_}->DESTROY(); }
 481     malloc_state(); # how do decide if this should be used? -- store something from the import
 482     print "Imager exiting\n";
 483   }
 484 }
 485
 486 # Load a filter plugin
 487
 488 sub load_plugin {
 489   my ($filename)=@_;
 490   my $i;
 491   my ($DSO_handle,$str)=DSO_open($filename);
 492   if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
 493   my %funcs=DSO_funclist($DSO_handle);
 494   if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf("  %2d: %s\n",$i++,$_); } }
 495   $i=0;
 496   for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
 497
 498   $DSOs{$filename}=[$DSO_handle,\%funcs];
 499
 500   for(keys %funcs) {
 501     my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
 502     $DEBUG && print "eval string:\n",$evstr,"\n";
 503     eval $evstr;
 504     print $@ if $@;
 505   }
 506   return 1;
 507 }
 508
 509 # Unload a plugin
 510
 511 sub unload_plugin {
 512   my ($filename)=@_;
 513
 514   if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
 515   my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
 516   for(keys %{$funcref}) {
 517     delete $filters{$_};
 518     $DEBUG && print "unloading: $_\n";
 519   }
 520   my $rc=DSO_close($DSO_handle);
 521   if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
 522   return 1;
 523 }
 524
 525 # take the results of i_error() and make a message out of it
 526 sub _error_as_msg {
 527   return join(": ", map $_->[0], i_errors());
 528 }
 529
 530 # this function tries to DWIM for color parameters
 531 #  color objects are used as is
 532 #  simple scalars are simply treated as single parameters to Imager::Color->new
 533 #  hashrefs are treated as named argument lists to Imager::Color->new
 534 #  arrayrefs are treated as list arguments to Imager::Color->new iff any
 535 #    parameter is > 1
 536 #  other arrayrefs are treated as list arguments to Imager::Color::Float
 537
 538 sub _color {
 539   my $arg = shift;
 540   # perl 5.6.0 seems to do weird things to $arg if we don't make an
 541   # explicitly stringified copy
 542   # I vaguely remember a bug on this on p5p, but couldn't find it
 543   # through bugs.perl.org (I had trouble getting it to find any bugs)
 544   my $copy = $arg . "";
 545   my $result;
 546
 547   if (ref $arg) {
 548     if (UNIVERSAL::isa($arg, "Imager::Color")
 549         || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
 550       $result = $arg;
 551     }
 552     else {
 553       if ($copy =~ /^HASH\(/) {
 554         $result = Imager::Color->new(%$arg);
 555       }
 556       elsif ($copy =~ /^ARRAY\(/) {
 557         $result = Imager::Color->new(@$arg);
 558       }
 559       else {
 560         $Imager::ERRSTR = "Not a color";
 561       }
 562     }
 563   }
 564   else {
 565     # assume Imager::Color::new knows how to handle it
 566     $result = Imager::Color->new($arg);
 567   }
 568
 569   return $result;
 570 }
 571
 572 sub _combine {
 573   my ($self, $combine, $default) = @_;
 574
 575   if (!defined $combine && ref $self) {
 576     $combine = $self->{combine};
 577   }
 578   defined $combine or $combine = $defaults{combine};
 579   defined $combine or $combine = $default;
 580
 581   if (exists $combine_types{$combine}) {
 582     $combine = $combine_types{$combine};
 583   }
 584
 585   return $combine;
 586 }
 587
 588 sub _valid_image {
 589   my ($self) = @_;
 590
 591   $self->{IMG} and return 1;
 592
 593   $self->_set_error('empty input image');
 594
 595   return;
 596 }
 597
 598 # returns first defined parameter
 599 sub _first {
 600   for (@_) {
 601     return $_ if defined $_;
 602   }
 603   return undef;
 604 }
 605
 606 #
 607 # Methods to be called on objects.
 608 #
 609
 610 # Create a new Imager object takes very few parameters.
 611 # usually you call this method and then call open from
 612 # the resulting object
 613
 614 sub new {
 615   my $class = shift;
 616   my $self ={};
 617   my %hsh=@_;
 618   bless $self,$class;
 619   $self->{IMG}=undef;    # Just to indicate what exists
 620   $self->{ERRSTR}=undef; #
 621   $self->{DEBUG}=$DEBUG;
 622   $self->{DEBUG} and print "Initialized Imager\n";
 623   if (defined $hsh{xsize} || defined $hsh{ysize}) {
 624     unless ($self->img_set(%hsh)) {
 625       $Imager::ERRSTR = $self->{ERRSTR};
 626       return;
 627     }
 628   }
 629   elsif (defined $hsh{file} ||
 630          defined $hsh{fh} ||
 631          defined $hsh{fd} ||
 632          defined $hsh{callback} ||
 633          defined $hsh{readcb} ||
 634          defined $hsh{data}) {
 635     # allow $img = Imager->new(file => $filename)
 636     my %extras;
 637
 638     # type is already used as a parameter to new(), rename it for the
 639     # call to read()
 640     if ($hsh{filetype}) {
 641       $extras{type} = $hsh{filetype};
 642     }
 643     unless ($self->read(%hsh, %extras)) {
 644       $Imager::ERRSTR = $self->{ERRSTR};
 645       return;
 646     }
 647   }
 648
 649   return $self;
 650 }
 651
 652 # Copy an entire image with no changes
 653 # - if an image has magic the copy of it will not be magical
 654
 655 sub copy {
 656   my $self = shift;
 657   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 658
 659   unless (defined wantarray) {
 660     my @caller = caller;
 661     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
 662     return;
 663   }
 664
 665   my $newcopy=Imager->new();
 666   $newcopy->{IMG} = i_copy($self->{IMG});
 667   return $newcopy;
 668 }
 669
 670 # Paste a region
 671
 672 sub paste {
 673   my $self = shift;
 674
 675   unless ($self->{IMG}) {
 676     $self->_set_error('empty input image');
 677     return;
 678   }
 679   my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
 680   my $src = $input{img} || $input{src};
 681   unless($src) {
 682     $self->_set_error("no source image");
 683     return;
 684   }
 685   $input{left}=0 if $input{left} <= 0;
 686   $input{top}=0 if $input{top} <= 0;
 687
 688   my($r,$b)=i_img_info($src->{IMG});
 689   my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
 690   my ($src_right, $src_bottom);
 691   if ($input{src_coords}) {
 692     ($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
 693   }
 694   else {
 695     if (defined $input{src_maxx}) {
 696       $src_right = $input{src_maxx};
 697     }
 698     elsif (defined $input{width}) {
 699       if ($input{width} <= 0) {
 700         $self->_set_error("paste: width must me positive");
 701         return;
 702       }
 703       $src_right = $src_left + $input{width};
 704     }
 705     else {
 706       $src_right = $r;
 707     }
 708     if (defined $input{src_maxy}) {
 709       $src_bottom = $input{src_maxy};
 710     }
 711     elsif (defined $input{height}) {
 712       if ($input{height} < 0) {
 713         $self->_set_error("paste: height must be positive");
 714         return;
 715       }
 716       $src_bottom = $src_top + $input{height};
 717     }
 718     else {
 719       $src_bottom = $b;
 720     }
 721   }
 722
 723   $src_right > $r and $src_right = $r;
 724   $src_bottom > $b and $src_bottom = $b;
 725
 726   if ($src_right <= $src_left
 727       || $src_bottom < $src_top) {
 728     $self->_set_error("nothing to paste");
 729     return;
 730   }
 731
 732   i_copyto($self->{IMG}, $src->{IMG},
 733            $src_left, $src_top, $src_right, $src_bottom,
 734            $input{left}, $input{top});
 735
 736   return $self;  # What should go here??
 737 }
 738
 739 # Crop an image - i.e. return a new image that is smaller
 740
 741 sub crop {
 742   my $self=shift;
 743   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
 744
 745   unless (defined wantarray) {
 746     my @caller = caller;
 747     warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
 748     return;
 749   }
 750
 751   my %hsh=@_;
 752
 753   my ($w, $h, $l, $r, $b, $t) =
 754     @hsh{qw(width height left right bottom top)};
 755
 756   # work through the various possibilities
 757   if (defined $l) {
 758     if (defined $w) {
 759       $r = $l + $w;
 760     }
 761     elsif (!defined $r) {
 762       $r = $self->getwidth;
 763     }
 764   }
 765   elsif (defined $r) {
 766     if (defined $w) {
 767       $l = $r - $w;
 768     }
 769     else {
 770       $l = 0;
 771     }
 772   }
 773   elsif (defined $w) {
 774     $l = int(0.5+($self->getwidth()-$w)/2);
 775     $r = $l + $w;
 776   }
 777   else {
 778     $l = 0;
 779     $r = $self->getwidth;
 780   }
 781   if (defined $t) {
 782     if (defined $h) {
 783       $b = $t + $h;
 784     }
 785     elsif (!defined $b) {
 786       $b = $self->getheight;
 787     }
 788   }
 789   elsif (defined $b) {
 790     if (defined $h) {
 791       $t = $b - $h;
 792     }
 793     else {
 794       $t = 0;
 795     }
 796   }
 797   elsif (defined $h) {
 798     $t=int(0.5+($self->getheight()-$h)/2);
 799     $b=$t+$h;
 800   }
 801   else {
 802     $t = 0;
 803     $b = $self->getheight;
 804   }
 805
 806   ($l,$r)=($r,$l) if $l>$r;
 807   ($t,$b)=($b,$t) if $t>$b;
 808
 809   $l < 0 and $l = 0;
 810   $r > $self->getwidth and $r = $self->getwidth;
 811   $t < 0 and $t = 0;
 812   $b > $self->getheight and $b = $self->getheight;
 813
 814   if ($l == $r || $t == $b) {
 815     $self->_set_error("resulting image would have no content");
 816     return;
 817   }
 818   if( $r < $l or $b < $t ) {
 819     $self->_set_error("attempting to crop outside of the image");
 820     return;
 821   }
 822   my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
 823
 824   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
 825   return $dst;
 826 }
 827
 828 sub _sametype {
 829   my ($self, %opts) = @_;
 830
 831   $self->{IMG} or return $self->_set_error("Not a valid image");
 832
 833   my $x = $opts{xsize} || $self->getwidth;
 834   my $y = $opts{ysize} || $self->getheight;
 835   my $channels = $opts{channels} || $self->getchannels;
 836
 837   my $out = Imager->new;
 838   if ($channels == $self->getchannels) {
 839     $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
 840   }
 841   else {
 842     $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
 843   }
 844   unless ($out->{IMG}) {
 845     $self->{ERRSTR} = $self->_error_as_msg;
 846     return;
 847   }
 848
 849   return $out;
 850 }
 851
 852 # Sets an image to a certain size and channel number
 853 # if there was previously data in the image it is discarded
 854
 855 sub img_set {
 856   my $self=shift;
 857
 858   my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
 859
 860   if (defined($self->{IMG})) {
 861     # let IIM_DESTROY destroy it, it's possible this image is
 862     # referenced from a virtual image (like masked)
 863     #i_img_destroy($self->{IMG});
 864     undef($self->{IMG});
 865   }
 866
 867   if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
 868     $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
 869                                  $hsh{maxcolors} || 256);
 870   }
 871   elsif ($hsh{bits} eq 'double') {
 872     $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 873   }
 874   elsif ($hsh{bits} == 16) {
 875     $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
 876   }
 877   else {
 878     $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
 879                                      $hsh{'channels'});
 880   }
 881
 882   unless ($self->{IMG}) {
 883     $self->{ERRSTR} = Imager->_error_as_msg();
 884     return;
 885   }
 886
 887   $self;
 888 }
 889
 890 # created a masked version of the current image
 891 sub masked {
 892   my $self = shift;
 893
 894   $self or return undef;
 895   my %opts = (left    => 0,
 896               top     => 0,
 897               right   => $self->getwidth,
 898               bottom  => $self->getheight,
 899               @_);
 900   my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
 901
 902   my $result = Imager->new;
 903   $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
 904                                     $opts{top}, $opts{right} - $opts{left},
 905                                     $opts{bottom} - $opts{top});
 906   unless ($result->{IMG}) {
 907     $self->_set_error(Imager->_error_as_msg);
 908     return;
 909   }
 910
 911   # keep references to the mask and base images so they don't
 912   # disappear on us
 913   $result->{DEPENDS} = [ $self->{IMG}, $mask ];
 914
 915   return $result;
 916 }
 917
 918 # convert an RGB image into a paletted image
 919 sub to_paletted {
 920   my $self = shift;
 921   my $opts;
 922   if (@_ != 1 && !ref $_[0]) {
 923     $opts = { @_ };
 924   }
 925   else {
 926     $opts = shift;
 927   }
 928
 929   unless (defined wantarray) {
 930     my @caller = caller;
 931     warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
 932     return;
 933   }
 934
 935   my $result = Imager->new;
 936   $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
 937
 938   #print "Type ", i_img_type($result->{IMG}), "\n";
 939
 940   if ($result->{IMG}) {
 941     return $result;
 942   }
 943   else {
 944     $self->{ERRSTR} = $self->_error_as_msg;
 945     return;
 946   }
 947 }
 948
 949 # convert a paletted (or any image) to an 8-bit/channel RGB images
 950 sub to_rgb8 {
 951   my $self = shift;
 952   my $result;
 953
 954   unless (defined wantarray) {
 955     my @caller = caller;
 956     warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
 957     return;
 958   }
 959
 960   if ($self->{IMG}) {
 961     $result = Imager->new;
 962     $result->{IMG} = i_img_to_rgb($self->{IMG})
 963       or undef $result;
 964   }
 965
 966   return $result;
 967 }
 968
 969 # convert a paletted (or any image) to an 8-bit/channel RGB images
 970 sub to_rgb16 {
 971   my $self = shift;
 972   my $result;
 973
 974   unless (defined wantarray) {
 975     my @caller = caller;
 976     warn "to_rgb16() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
 977     return;
 978   }
 979
 980   if ($self->{IMG}) {
 981     $result = Imager->new;
 982     $result->{IMG} = i_img_to_rgb16($self->{IMG})
 983       or undef $result;
 984   }
 985
 986   return $result;
 987 }
 988
 989 sub addcolors {
 990   my $self = shift;
 991   my %opts = (colors=>[], @_);
 992
 993   unless ($self->{IMG}) {
 994     $self->_set_error("empty input image");
 995     return;
 996   }
 997
 998   my @colors = @{$opts{colors}}
 999     or return undef;
1000
1001   for my $color (@colors) {
1002     $color = _color($color);
1003     unless ($color) {
1004       $self->_set_error($Imager::ERRSTR);
1005       return;
1006     }
1007   }
1008
1009   return i_addcolors($self->{IMG}, @colors);
1010 }
1011
1012 sub setcolors {
1013   my $self = shift;
1014   my %opts = (start=>0, colors=>[], @_);
1015
1016   unless ($self->{IMG}) {
1017     $self->_set_error("empty input image");
1018     return;
1019   }
1020
1021   my @colors = @{$opts{colors}}
1022     or return undef;
1023
1024   for my $color (@colors) {
1025     $color = _color($color);
1026     unless ($color) {
1027       $self->_set_error($Imager::ERRSTR);
1028       return;
1029     }
1030   }
1031
1032   return i_setcolors($self->{IMG}, $opts{start}, @colors);
1033 }
1034
1035 sub getcolors {
1036   my $self = shift;
1037   my %opts = @_;
1038   if (!exists $opts{start} && !exists $opts{count}) {
1039     # get them all
1040     $opts{start} = 0;
1041     $opts{count} = $self->colorcount;
1042   }
1043   elsif (!exists $opts{count}) {
1044     $opts{count} = 1;
1045   }
1046   elsif (!exists $opts{start}) {
1047     $opts{start} = 0;
1048   }
1049
1050   $self->{IMG} and
1051     return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
1052 }
1053
1054 sub colorcount {
1055   i_colorcount($_[0]{IMG});
1056 }
1057
1058 sub maxcolors {
1059   i_maxcolors($_[0]{IMG});
1060 }
1061
1062 sub findcolor {
1063   my $self = shift;
1064   my %opts = @_;
1065   $opts{color} or return undef;
1066
1067   $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
1068 }
1069
1070 sub bits {
1071   my $self = shift;
1072   my $bits = $self->{IMG} && i_img_bits($self->{IMG});
1073   if ($bits && $bits == length(pack("d", 1)) * 8) {
1074     $bits = 'double';
1075   }
1076   $bits;
1077 }
1078
1079 sub type {
1080   my $self = shift;
1081   if ($self->{IMG}) {
1082     return i_img_type($self->{IMG}) ? "paletted" : "direct";
1083   }
1084 }
1085
1086 sub virtual {
1087   my $self = shift;
1088   $self->{IMG} and i_img_virtual($self->{IMG});
1089 }
1090
1091 sub is_bilevel {
1092   my ($self) = @_;
1093
1094   $self->{IMG} or return;
1095
1096   return i_img_is_monochrome($self->{IMG});
1097 }
1098
1099 sub tags {
1100   my ($self, %opts) = @_;
1101
1102   $self->{IMG} or return;
1103
1104   if (defined $opts{name}) {
1105     my @result;
1106     my $start = 0;
1107     my $found;
1108     while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1109       push @result, (i_tags_get($self->{IMG}, $found))[1];
1110       $start = $found+1;
1111     }
1112     return wantarray ? @result : $result[0];
1113   }
1114   elsif (defined $opts{code}) {
1115     my @result;
1116     my $start = 0;
1117     my $found;
1118     while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1119       push @result, (i_tags_get($self->{IMG}, $found))[1];
1120       $start = $found+1;
1121     }
1122     return @result;
1123   }
1124   else {
1125     if (wantarray) {
1126       return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1127     }
1128     else {
1129       return i_tags_count($self->{IMG});
1130     }
1131   }
1132 }
1133
1134 sub addtag {
1135   my $self = shift;
1136   my %opts = @_;
1137
1138   return -1 unless $self->{IMG};
1139   if ($opts{name}) {
1140     if (defined $opts{value}) {
1141       if ($opts{value} =~ /^\d+$/) {
1142         # add as a number
1143         return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1144       }
1145       else {
1146         return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1147       }
1148     }
1149     elsif (defined $opts{data}) {
1150       # force addition as a string
1151       return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1152     }
1153     else {
1154       $self->{ERRSTR} = "No value supplied";
1155       return undef;
1156     }
1157   }
1158   elsif ($opts{code}) {
1159     if (defined $opts{value}) {
1160       if ($opts{value} =~ /^\d+$/) {
1161         # add as a number
1162         return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1163       }
1164       else {
1165         return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1166       }
1167     }
1168     elsif (defined $opts{data}) {
1169       # force addition as a string
1170       return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1171     }
1172     else {
1173       $self->{ERRSTR} = "No value supplied";
1174       return undef;
1175     }
1176   }
1177   else {
1178     return undef;
1179   }
1180 }
1181
1182 sub deltag {
1183   my $self = shift;
1184   my %opts = @_;
1185
1186   return 0 unless $self->{IMG};
1187
1188   if (defined $opts{'index'}) {
1189     return i_tags_delete($self->{IMG}, $opts{'index'});
1190   }
1191   elsif (defined $opts{name}) {
1192     return i_tags_delbyname($self->{IMG}, $opts{name});
1193   }
1194   elsif (defined $opts{code}) {
1195     return i_tags_delbycode($self->{IMG}, $opts{code});
1196   }
1197   else {
1198     $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1199     return 0;
1200   }
1201 }
1202
1203 sub settag {
1204   my ($self, %opts) = @_;
1205
1206   if ($opts{name}) {
1207     $self->deltag(name=>$opts{name});
1208     return $self->addtag(name=>$opts{name}, value=>$opts{value});
1209   }
1210   elsif (defined $opts{code}) {
1211     $self->deltag(code=>$opts{code});
1212     return $self->addtag(code=>$opts{code}, value=>$opts{value});
1213   }
1214   else {
1215     return undef;
1216   }
1217 }
1218
1219
1220 sub _get_reader_io {
1221   my ($self, $input) = @_;
1222
1223   if ($input->{io}) {
1224     return $input->{io}, undef;
1225   }
1226   elsif ($input->{fd}) {
1227     return io_new_fd($input->{fd});
1228   }
1229   elsif ($input->{fh}) {
1230     my $fd = fileno($input->{fh});
1231     unless (defined $fd) {
1232       $self->_set_error("Handle in fh option not opened");
1233       return;
1234     }
1235     return io_new_fd($fd);
1236   }
1237   elsif ($input->{file}) {
1238     my $file = IO::File->new($input->{file}, "r");
1239     unless ($file) {
1240       $self->_set_error("Could not open $input->{file}: $!");
1241       return;
1242     }
1243     binmode $file;
1244     return (io_new_fd(fileno($file)), $file);
1245   }
1246   elsif ($input->{data}) {
1247     return io_new_buffer($input->{data});
1248   }
1249   elsif ($input->{callback} || $input->{readcb}) {
1250     if (!$input->{seekcb}) {
1251       $self->_set_error("Need a seekcb parameter");
1252     }
1253     if ($input->{maxbuffer}) {
1254       return io_new_cb($input->{writecb},
1255                        $input->{callback} || $input->{readcb},
1256                        $input->{seekcb}, $input->{closecb},
1257                        $input->{maxbuffer});
1258     }
1259     else {
1260       return io_new_cb($input->{writecb},
1261                        $input->{callback} || $input->{readcb},
1262                        $input->{seekcb}, $input->{closecb});
1263     }
1264   }
1265   else {
1266     $self->_set_error("file/fd/fh/data/callback parameter missing");
1267     return;
1268   }
1269 }
1270
1271 sub _get_writer_io {
1272   my ($self, $input, $type) = @_;
1273
1274   if ($input->{io}) {
1275     return $input->{io};
1276   }
1277   elsif ($input->{fd}) {
1278     return io_new_fd($input->{fd});
1279   }
1280   elsif ($input->{fh}) {
1281     my $fd = fileno($input->{fh});
1282     unless (defined $fd) {
1283       $self->_set_error("Handle in fh option not opened");
1284       return;
1285     }
1286     # flush it
1287     my $oldfh = select($input->{fh});
1288     # flush anything that's buffered, and make sure anything else is flushed
1289     $| = 1;
1290     select($oldfh);
1291     return io_new_fd($fd);
1292   }
1293   elsif ($input->{file}) {
1294     my $fh = new IO::File($input->{file},"w+");
1295     unless ($fh) {
1296       $self->_set_error("Could not open file $input->{file}: $!");
1297       return;
1298     }
1299     binmode($fh) or die;
1300     return (io_new_fd(fileno($fh)), $fh);
1301   }
1302   elsif ($input->{data}) {
1303     return io_new_bufchain();
1304   }
1305   elsif ($input->{callback} || $input->{writecb}) {
1306     if ($input->{maxbuffer}) {
1307       return io_new_cb($input->{callback} || $input->{writecb},
1308                        $input->{readcb},
1309                        $input->{seekcb}, $input->{closecb},
1310                        $input->{maxbuffer});
1311     }
1312     else {
1313       return io_new_cb($input->{callback} || $input->{writecb},
1314                        $input->{readcb},
1315                        $input->{seekcb}, $input->{closecb});
1316     }
1317   }
1318   else {
1319     $self->_set_error("file/fd/fh/data/callback parameter missing");
1320     return;
1321   }
1322 }
1323
1324 # Read an image from file
1325
1326 sub read {
1327   my $self = shift;
1328   my %input=@_;
1329
1330   if (defined($self->{IMG})) {
1331     # let IIM_DESTROY do the destruction, since the image may be
1332     # referenced from elsewhere
1333     #i_img_destroy($self->{IMG});
1334     undef($self->{IMG});
1335   }
1336
1337   my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1338
1339   unless ($input{'type'}) {
1340     $input{'type'} = i_test_format_probe($IO, -1);
1341   }
1342
1343   unless ($input{'type'}) {
1344           $self->_set_error('type parameter missing and not possible to guess from extension');
1345     return undef;
1346   }
1347
1348   _reader_autoload($input{type});
1349
1350   if ($readers{$input{type}} && $readers{$input{type}}{single}) {
1351     return $readers{$input{type}}{single}->($self, $IO, %input);
1352   }
1353
1354   unless ($formats_low{$input{'type'}}) {
1355     my $read_types = join ', ', sort Imager->read_types();
1356     $self->_set_error("format '$input{'type'}' not supported - formats $read_types available for reading");
1357     return;
1358   }
1359
1360   my $allow_incomplete = $input{allow_incomplete};
1361   defined $allow_incomplete or $allow_incomplete = 0;
1362
1363   if ( $input{'type'} eq 'pnm' ) {
1364     $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
1365     if ( !defined($self->{IMG}) ) {
1366       $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1367       return undef;
1368     }
1369     $self->{DEBUG} && print "loading a pnm file\n";
1370     return $self;
1371   }
1372
1373   if ( $input{'type'} eq 'bmp' ) {
1374     $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
1375     if ( !defined($self->{IMG}) ) {
1376       $self->{ERRSTR}=$self->_error_as_msg();
1377       return undef;
1378     }
1379     $self->{DEBUG} && print "loading a bmp file\n";
1380   }
1381
1382   if ( $input{'type'} eq 'gif' ) {
1383     if ($input{colors} && !ref($input{colors})) {
1384       # must be a reference to a scalar that accepts the colour map
1385       $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1386       return undef;
1387     }
1388     if ($input{'gif_consolidate'}) {
1389       if ($input{colors}) {
1390         my $colors;
1391         ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1392         if ($colors) {
1393           ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1394         }
1395       }
1396       else {
1397         $self->{IMG} =i_readgif_wiol( $IO );
1398       }
1399     }
1400     else {
1401       my $page = $input{'page'};
1402       defined $page or $page = 0;
1403       $self->{IMG} = i_readgif_single_wiol( $IO, $page );
1404       if ($self->{IMG} && $input{colors}) {
1405         ${ $input{colors} } =
1406           [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ];
1407       }
1408     }
1409
1410     if ( !defined($self->{IMG}) ) {
1411       $self->{ERRSTR}=$self->_error_as_msg();
1412       return undef;
1413     }
1414     $self->{DEBUG} && print "loading a gif file\n";
1415   }
1416
1417   if ( $input{'type'} eq 'tga' ) {
1418     $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1419     if ( !defined($self->{IMG}) ) {
1420       $self->{ERRSTR}=$self->_error_as_msg();
1421       return undef;
1422     }
1423     $self->{DEBUG} && print "loading a tga file\n";
1424   }
1425
1426   if ( $input{'type'} eq 'raw' ) {
1427     unless ( $input{xsize} && $input{ysize} ) {
1428       $self->_set_error('missing xsize or ysize parameter for raw');
1429       return undef;
1430     }
1431
1432     my $interleave = _first($input{raw_interleave}, $input{interleave});
1433     unless (defined $interleave) {
1434       my @caller = caller;
1435       warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
1436       $interleave = 1;
1437     }
1438     my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
1439     my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
1440
1441     $self->{IMG} = i_readraw_wiol( $IO,
1442                                    $input{xsize},
1443                                    $input{ysize},
1444                                    $data_ch,
1445                                    $store_ch,
1446                                    $interleave);
1447     if ( !defined($self->{IMG}) ) {
1448       $self->{ERRSTR}=$self->_error_as_msg();
1449       return undef;
1450     }
1451     $self->{DEBUG} && print "loading a raw file\n";
1452   }
1453
1454   return $self;
1455 }
1456
1457 sub register_reader {
1458   my ($class, %opts) = @_;
1459
1460   defined $opts{type}
1461     or die "register_reader called with no type parameter\n";
1462
1463   my $type = $opts{type};
1464
1465   defined $opts{single} || defined $opts{multiple}
1466     or die "register_reader called with no single or multiple parameter\n";
1467
1468   $readers{$type} = {  };
1469   if ($opts{single}) {
1470     $readers{$type}{single} = $opts{single};
1471   }
1472   if ($opts{multiple}) {
1473     $readers{$type}{multiple} = $opts{multiple};
1474   }
1475
1476   return 1;
1477 }
1478
1479 sub register_writer {
1480   my ($class, %opts) = @_;
1481
1482   defined $opts{type}
1483     or die "register_writer called with no type parameter\n";
1484
1485   my $type = $opts{type};
1486
1487   defined $opts{single} || defined $opts{multiple}
1488     or die "register_writer called with no single or multiple parameter\n";
1489
1490   $writers{$type} = {  };
1491   if ($opts{single}) {
1492     $writers{$type}{single} = $opts{single};
1493   }
1494   if ($opts{multiple}) {
1495     $writers{$type}{multiple} = $opts{multiple};
1496   }
1497
1498   return 1;
1499 }
1500
1501 sub read_types {
1502   my %types =
1503     (
1504      map { $_ => 1 }
1505      keys %readers,
1506      grep($file_formats{$_}, keys %formats),
1507      qw(ico sgi), # formats not handled directly, but supplied with Imager
1508     );
1509
1510   return keys %types;
1511 }
1512
1513 sub write_types {
1514   my %types =
1515     (
1516      map { $_ => 1 }
1517      keys %writers,
1518      grep($file_formats{$_}, keys %formats),
1519      qw(ico sgi), # formats not handled directly, but supplied with Imager
1520     );
1521
1522   return keys %types;
1523 }
1524
1525 # probes for an Imager::File::whatever module
1526 sub _reader_autoload {
1527   my $type = shift;
1528
1529   return if $formats_low{$type} || $readers{$type};
1530
1531   return unless $type =~ /^\w+$/;
1532
1533   my $file = "Imager/File/\U$type\E.pm";
1534
1535   unless ($attempted_to_load{$file}) {
1536     eval {
1537       ++$attempted_to_load{$file};
1538       require $file;
1539     };
1540     if ($@) {
1541       # try to get a reader specific module
1542       my $file = "Imager/File/\U$type\EReader.pm";
1543       unless ($attempted_to_load{$file}) {
1544         eval {
1545           ++$attempted_to_load{$file};
1546           require $file;
1547         };
1548       }
1549     }
1550   }
1551 }
1552
1553 # probes for an Imager::File::whatever module
1554 sub _writer_autoload {
1555   my $type = shift;
1556
1557   return if $formats_low{$type} || $readers{$type};
1558
1559   return unless $type =~ /^\w+$/;
1560
1561   my $file = "Imager/File/\U$type\E.pm";
1562
1563   unless ($attempted_to_load{$file}) {
1564     eval {
1565       ++$attempted_to_load{$file};
1566       require $file;
1567     };
1568     if ($@) {
1569       # try to get a writer specific module
1570       my $file = "Imager/File/\U$type\EWriter.pm";
1571       unless ($attempted_to_load{$file}) {
1572         eval {
1573           ++$attempted_to_load{$file};
1574           require $file;
1575         };
1576       }
1577     }
1578   }
1579 }
1580
1581 sub _fix_gif_positions {
1582   my ($opts, $opt, $msg, @imgs) = @_;
1583
1584   my $positions = $opts->{'gif_positions'};
1585   my $index = 0;
1586   for my $pos (@$positions) {
1587     my ($x, $y) = @$pos;
1588     my $img = $imgs[$index++];
1589     $img->settag(name=>'gif_left', value=>$x);
1590     $img->settag(name=>'gif_top', value=>$y) if defined $y;
1591   }
1592   $$msg .= "replaced with the gif_left and gif_top tags";
1593 }
1594
1595 my %obsolete_opts =
1596   (
1597    gif_each_palette=>'gif_local_map',
1598    interlace       => 'gif_interlace',
1599    gif_delays => 'gif_delay',
1600    gif_positions => \&_fix_gif_positions,
1601    gif_loop_count => 'gif_loop',
1602   );
1603
1604 # options that should be converted to colors
1605 my %color_opts = map { $_ => 1 } qw/i_background/;
1606
1607 sub _set_opts {
1608   my ($self, $opts, $prefix, @imgs) = @_;
1609
1610   for my $opt (keys %$opts) {
1611     my $tagname = $opt;
1612     if ($obsolete_opts{$opt}) {
1613       my $new = $obsolete_opts{$opt};
1614       my $msg = "Obsolete option $opt ";
1615       if (ref $new) {
1616         $new->($opts, $opt, \$msg, @imgs);
1617       }
1618       else {
1619         $msg .= "replaced with the $new tag ";
1620         $tagname = $new;
1621       }
1622       $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1623       warn $msg if $warn_obsolete && $^W;
1624     }
1625     next unless $tagname =~ /^\Q$prefix/;
1626     my $value = $opts->{$opt};
1627     if ($color_opts{$opt}) {
1628       $value = _color($value);
1629       unless ($value) {
1630         $self->_set_error($Imager::ERRSTR);
1631         return;
1632       }
1633     }
1634     if (ref $value) {
1635       if (UNIVERSAL::isa($value, "Imager::Color")) {
1636         my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1637         for my $img (@imgs) {
1638           $img->settag(name=>$tagname, value=>$tag);
1639         }
1640       }
1641       elsif (ref($value) eq 'ARRAY') {
1642         for my $i (0..$#$value) {
1643           my $val = $value->[$i];
1644           if (ref $val) {
1645             if (UNIVERSAL::isa($val, "Imager::Color")) {
1646               my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1647               $i < @imgs and
1648                 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1649             }
1650             else {
1651               $self->_set_error("Unknown reference type " . ref($value) .
1652                                 " supplied in array for $opt");
1653               return;
1654             }
1655           }
1656           else {
1657             $i < @imgs
1658               and $imgs[$i]->settag(name=>$tagname, value=>$val);
1659           }
1660         }
1661       }
1662       else {
1663         $self->_set_error("Unknown reference type " . ref($value) .
1664                           " supplied for $opt");
1665         return;
1666       }
1667     }
1668     else {
1669       # set it as a tag for every image
1670       for my $img (@imgs) {
1671         $img->settag(name=>$tagname, value=>$value);
1672       }
1673     }
1674   }
1675
1676   return 1;
1677 }
1678
1679 # Write an image to file
1680 sub write {
1681   my $self = shift;
1682   my %input=(jpegquality=>75,
1683              gifquant=>'mc',
1684              lmdither=>6.0,
1685              lmfixed=>[],
1686              idstring=>"",
1687              compress=>1,
1688              wierdpack=>0,
1689              fax_fine=>1, @_);
1690   my $rc;
1691
1692   $self->_set_opts(\%input, "i_", $self)
1693     or return undef;
1694
1695   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1696
1697   if (!$input{'type'} and $input{file}) {
1698     $input{'type'}=$FORMATGUESS->($input{file});
1699   }
1700   if (!$input{'type'}) {
1701     $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1702     return undef;
1703   }
1704
1705   _writer_autoload($input{type});
1706
1707   my ($IO, $fh);
1708   if ($writers{$input{type}} && $writers{$input{type}}{single}) {
1709     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1710       or return undef;
1711
1712     $writers{$input{type}}{single}->($self, $IO, %input)
1713       or return undef;
1714   }
1715   else {
1716     if (!$formats_low{$input{'type'}}) {
1717       my $write_types = join ', ', sort Imager->write_types();
1718       $self->_set_error("format '$input{'type'}' not supported - formats $write_types available for writing");
1719       return undef;
1720     }
1721
1722     ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1723       or return undef;
1724
1725     if ( $input{'type'} eq 'pnm' ) {
1726       $self->_set_opts(\%input, "pnm_", $self)
1727         or return undef;
1728       if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1729         $self->{ERRSTR} = $self->_error_as_msg();
1730         return undef;
1731       }
1732       $self->{DEBUG} && print "writing a pnm file\n";
1733     } elsif ( $input{'type'} eq 'raw' ) {
1734       $self->_set_opts(\%input, "raw_", $self)
1735         or return undef;
1736       if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1737         $self->{ERRSTR} = $self->_error_as_msg();
1738         return undef;
1739       }
1740       $self->{DEBUG} && print "writing a raw file\n";
1741     } elsif ( $input{'type'} eq 'jpeg' ) {
1742       $self->_set_opts(\%input, "jpeg_", $self)
1743         or return undef;
1744       $self->_set_opts(\%input, "exif_", $self)
1745         or return undef;
1746       if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1747         $self->{ERRSTR} = $self->_error_as_msg();
1748         return undef;
1749       }
1750       $self->{DEBUG} && print "writing a jpeg file\n";
1751     } elsif ( $input{'type'} eq 'bmp' ) {
1752       $self->_set_opts(\%input, "bmp_", $self)
1753         or return undef;
1754       if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1755         $self->{ERRSTR} = $self->_error_as_msg;
1756         return undef;
1757       }
1758       $self->{DEBUG} && print "writing a bmp file\n";
1759     } elsif ( $input{'type'} eq 'tga' ) {
1760       $self->_set_opts(\%input, "tga_", $self)
1761         or return undef;
1762
1763       if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1764         $self->{ERRSTR}=$self->_error_as_msg();
1765         return undef;
1766       }
1767       $self->{DEBUG} && print "writing a tga file\n";
1768     } elsif ( $input{'type'} eq 'gif' ) {
1769       $self->_set_opts(\%input, "gif_", $self)
1770         or return undef;
1771       # compatibility with the old interfaces
1772       if ($input{gifquant} eq 'lm') {
1773         $input{make_colors} = 'addi';
1774         $input{translate} = 'perturb';
1775         $input{perturb} = $input{lmdither};
1776       } elsif ($input{gifquant} eq 'gen') {
1777         # just pass options through
1778       } else {
1779         $input{make_colors} = 'webmap'; # ignored
1780         $input{translate} = 'giflib';
1781       }
1782       if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1783         $self->{ERRSTR} = $self->_error_as_msg;
1784         return;
1785       }
1786     }
1787   }
1788
1789   if (exists $input{'data'}) {
1790     my $data = io_slurp($IO);
1791     if (!$data) {
1792       $self->{ERRSTR}='Could not slurp from buffer';
1793       return undef;
1794     }
1795     ${$input{data}} = $data;
1796   }
1797   return $self;
1798 }
1799
1800 sub write_multi {
1801   my ($class, $opts, @images) = @_;
1802
1803   my $type = $opts->{type};
1804
1805   if (!$type && $opts->{'file'}) {
1806     $type = $FORMATGUESS->($opts->{'file'});
1807   }
1808   unless ($type) {
1809     $class->_set_error('type parameter missing and not possible to guess from extension');
1810     return;
1811   }
1812   # translate to ImgRaw
1813   if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1814     $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1815     return 0;
1816   }
1817   $class->_set_opts($opts, "i_", @images)
1818     or return;
1819   my @work = map $_->{IMG}, @images;
1820
1821   _writer_autoload($type);
1822
1823   my ($IO, $file);
1824   if ($writers{$type} && $writers{$type}{multiple}) {
1825     ($IO, $file) = $class->_get_writer_io($opts, $type)
1826       or return undef;
1827
1828     $writers{$type}{multiple}->($class, $IO, $opts, @images)
1829       or return undef;
1830   }
1831   else {
1832     if (!$formats{$type}) {
1833       my $write_types = join ', ', sort Imager->write_types();
1834       $class->_set_error("format '$type' not supported - formats $write_types available for writing");
1835       return undef;
1836     }
1837
1838     ($IO, $file) = $class->_get_writer_io($opts, $type)
1839       or return undef;
1840
1841     if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
1842     }
1843     else {
1844       if (@images == 1) {
1845         unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1846           return 1;
1847         }
1848       }
1849       else {
1850         $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1851         return 0;
1852       }
1853     }
1854   }
1855
1856   if (exists $opts->{'data'}) {
1857     my $data = io_slurp($IO);
1858     if (!$data) {
1859       Imager->_set_error('Could not slurp from buffer');
1860       return undef;
1861     }
1862     ${$opts->{data}} = $data;
1863   }
1864   return 1;
1865 }
1866
1867 # read multiple images from a file
1868 sub read_multi {
1869   my ($class, %opts) = @_;
1870
1871   my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1872     or return;
1873
1874   my $type = $opts{'type'};
1875   unless ($type) {
1876     $type = i_test_format_probe($IO, -1);
1877   }
1878
1879   if ($opts{file} && !$type) {
1880     # guess the type
1881     $type = $FORMATGUESS->($opts{file});
1882   }
1883
1884   unless ($type) {
1885     $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1886     return;
1887   }
1888
1889   _reader_autoload($type);
1890
1891   if ($readers{$type} && $readers{$type}{multiple}) {
1892     return $readers{$type}{multiple}->($IO, %opts);
1893   }
1894
1895   unless ($formats{$type}) {
1896     my $read_types = join ', ', sort Imager->read_types();
1897     Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
1898     return;
1899   }
1900
1901   my @imgs;
1902   if ($type eq 'pnm') {
1903     @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
1904   }
1905   else {
1906     my $img = Imager->new;
1907     if ($img->read(%opts, io => $IO, type => $type)) {
1908       return ( $img );
1909     }
1910     Imager->_set_error($img->errstr);
1911     return;
1912   }
1913
1914   if (!@imgs) {
1915     $ERRSTR = _error_as_msg();
1916   return;
1917   }
1918   return map {
1919         bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1920       } @imgs;
1921 }
1922
1923 # Destroy an Imager object
1924
1925 sub DESTROY {
1926   my $self=shift;
1927   #    delete $instances{$self};
1928   if (defined($self->{IMG})) {
1929     # the following is now handled by the XS DESTROY method for
1930     # Imager::ImgRaw object
1931     # Re-enabling this will break virtual images
1932     # tested for in t/t020masked.t
1933     # i_img_destroy($self->{IMG});
1934     undef($self->{IMG});
1935   } else {
1936 #    print "Destroy Called on an empty image!\n"; # why did I put this here??
1937   }
1938 }
1939
1940 # Perform an inplace filter of an image
1941 # that is the image will be overwritten with the data
1942
1943 sub filter {
1944   my $self=shift;
1945   my %input=@_;
1946   my %hsh;
1947   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1948
1949   if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
1950
1951   if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
1952     $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1953   }
1954
1955   if ($filters{$input{'type'}}{names}) {
1956     my $names = $filters{$input{'type'}}{names};
1957     for my $name (keys %$names) {
1958       if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1959         $input{$name} = $names->{$name}{$input{$name}};
1960       }
1961     }
1962   }
1963   if (defined($filters{$input{'type'}}{defaults})) {
1964     %hsh=( image => $self->{IMG},
1965            imager => $self,
1966            %{$filters{$input{'type'}}{defaults}},
1967            %input );
1968   } else {
1969     %hsh=( image => $self->{IMG},
1970            imager => $self,
1971            %input );
1972   }
1973
1974   my @cs=@{$filters{$input{'type'}}{callseq}};
1975
1976   for(@cs) {
1977     if (!defined($hsh{$_})) {
1978       $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
1979     }
1980   }
1981
1982   eval {
1983     local $SIG{__DIE__}; # we don't want this processed by confess, etc
1984     &{$filters{$input{'type'}}{callsub}}(%hsh);
1985   };
1986   if ($@) {
1987     chomp($self->{ERRSTR} = $@);
1988     return;
1989   }
1990
1991   my @b=keys %hsh;
1992
1993   $self->{DEBUG} && print "callseq is: @cs\n";
1994   $self->{DEBUG} && print "matching callseq is: @b\n";
1995
1996   return $self;
1997 }
1998
1999 sub register_filter {
2000   my $class = shift;
2001   my %hsh = ( defaults => {}, @_ );
2002
2003   defined $hsh{type}
2004     or die "register_filter() with no type\n";
2005   defined $hsh{callsub}
2006     or die "register_filter() with no callsub\n";
2007   defined $hsh{callseq}
2008     or die "register_filter() with no callseq\n";
2009
2010   exists $filters{$hsh{type}}
2011     and return;
2012
2013   $filters{$hsh{type}} = \%hsh;
2014
2015   return 1;
2016 }
2017
2018 sub scale_calculate {
2019   my $self = shift;
2020
2021   my %opts = ('type'=>'max', @_);
2022
2023   # none of these should be references
2024   for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2025     if (defined $opts{$name} && ref $opts{$name}) {
2026       $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2027       return;
2028     }
2029   }
2030
2031   my ($x_scale, $y_scale);
2032   my $width = $opts{width};
2033   my $height = $opts{height};
2034   if (ref $self) {
2035     defined $width or $width = $self->getwidth;
2036     defined $height or $height = $self->getheight;
2037   }
2038   else {
2039     unless (defined $width && defined $height) {
2040       $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2041       return;
2042     }
2043   }
2044
2045   if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2046     $x_scale = $opts{'xscalefactor'};
2047     $y_scale = $opts{'yscalefactor'};
2048   }
2049   elsif ($opts{'xscalefactor'}) {
2050     $x_scale = $opts{'xscalefactor'};
2051     $y_scale = $opts{'scalefactor'} || $x_scale;
2052   }
2053   elsif ($opts{'yscalefactor'}) {
2054     $y_scale = $opts{'yscalefactor'};
2055     $x_scale = $opts{'scalefactor'} || $y_scale;
2056   }
2057   else {
2058     $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2059   }
2060
2061   # work out the scaling
2062   if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
2063     my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2064                         $opts{ypixels} / $height );
2065     if ($opts{'type'} eq 'min') {
2066       $x_scale = $y_scale = _min($xpix,$ypix);
2067     }
2068     elsif ($opts{'type'} eq 'max') {
2069       $x_scale = $y_scale = _max($xpix,$ypix);
2070     }
2071     elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2072       $x_scale = $xpix;
2073       $y_scale = $ypix;
2074     }
2075     else {
2076       $self->_set_error('invalid value for type parameter');
2077       return;
2078     }
2079   } elsif ($opts{xpixels}) {
2080     $x_scale = $y_scale = $opts{xpixels} / $width;
2081   }
2082   elsif ($opts{ypixels}) {
2083     $x_scale = $y_scale = $opts{ypixels}/$height;
2084   }
2085   elsif ($opts{constrain} && ref $opts{constrain}
2086          && $opts{constrain}->can('constrain')) {
2087     # we've been passed an Image::Math::Constrain object or something
2088     # that looks like one
2089     my $scalefactor;
2090     (undef, undef, $scalefactor)
2091       = $opts{constrain}->constrain($self->getwidth, $self->getheight);
2092     unless ($scalefactor) {
2093       $self->_set_error('constrain method failed on constrain parameter');
2094       return;
2095     }
2096     $x_scale = $y_scale = $scalefactor;
2097   }
2098
2099   my $new_width = int($x_scale * $width + 0.5);
2100   $new_width > 0 or $new_width = 1;
2101   my $new_height = int($y_scale * $height + 0.5);
2102   $new_height > 0 or $new_height = 1;
2103
2104   return ($x_scale, $y_scale, $new_width, $new_height);
2105
2106 }
2107
2108 # Scale an image to requested size and return the scaled version
2109
2110 sub scale {
2111   my $self=shift;
2112   my %opts = (qtype=>'normal' ,@_);
2113   my $img = Imager->new();
2114   my $tmp = Imager->new();
2115
2116   unless (defined wantarray) {
2117     my @caller = caller;
2118     warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2119     return;
2120   }
2121
2122   unless ($self->{IMG}) {
2123     $self->_set_error('empty input image');
2124     return undef;
2125   }
2126
2127   my ($x_scale, $y_scale, $new_width, $new_height) =
2128     $self->scale_calculate(%opts)
2129       or return;
2130
2131   if ($opts{qtype} eq 'normal') {
2132     $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
2133     if ( !defined($tmp->{IMG}) ) {
2134       $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
2135       return undef;
2136     }
2137     $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
2138     if ( !defined($img->{IMG}) ) {
2139       $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
2140       return undef;
2141     }
2142
2143     return $img;
2144   }
2145   elsif ($opts{'qtype'} eq 'preview') {
2146     $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
2147     if ( !defined($img->{IMG}) ) {
2148       $self->{ERRSTR}='unable to scale image';
2149       return undef;
2150     }
2151     return $img;
2152   }
2153   elsif ($opts{'qtype'} eq 'mixing') {
2154     $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2155     unless ($img->{IMG}) {
2156       $self->_set_error(Imager->_error_as_msg);
2157       return;
2158     }
2159     return $img;
2160   }
2161   else {
2162     $self->_set_error('invalid value for qtype parameter');
2163     return undef;
2164   }
2165 }
2166
2167 # Scales only along the X axis
2168
2169 sub scaleX {
2170   my $self = shift;
2171   my %opts = ( scalefactor=>0.5, @_ );
2172
2173   unless (defined wantarray) {
2174     my @caller = caller;
2175     warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2176     return;
2177   }
2178
2179   unless ($self->{IMG}) {
2180     $self->{ERRSTR} = 'empty input image';
2181     return undef;
2182   }
2183
2184   my $img = Imager->new();
2185
2186   my $scalefactor = $opts{scalefactor};
2187
2188   if ($opts{pixels}) {
2189     $scalefactor = $opts{pixels} / $self->getwidth();
2190   }
2191
2192   unless ($self->{IMG}) {
2193     $self->{ERRSTR}='empty input image';
2194     return undef;
2195   }
2196
2197   $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2198
2199   if ( !defined($img->{IMG}) ) {
2200     $self->{ERRSTR} = 'unable to scale image';
2201     return undef;
2202   }
2203
2204   return $img;
2205 }
2206
2207 # Scales only along the Y axis
2208
2209 sub scaleY {
2210   my $self = shift;
2211   my %opts = ( scalefactor => 0.5, @_ );
2212
2213   unless (defined wantarray) {
2214     my @caller = caller;
2215     warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2216     return;
2217   }
2218
2219   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2220
2221   my $img = Imager->new();
2222
2223   my $scalefactor = $opts{scalefactor};
2224
2225   if ($opts{pixels}) {
2226     $scalefactor = $opts{pixels} / $self->getheight();
2227   }
2228
2229   unless ($self->{IMG}) {
2230     $self->{ERRSTR} = 'empty input image';
2231     return undef;
2232   }
2233   $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2234
2235   if ( !defined($img->{IMG}) ) {
2236     $self->{ERRSTR} = 'unable to scale image';
2237     return undef;
2238   }
2239
2240   return $img;
2241 }
2242
2243 # Transform returns a spatial transformation of the input image
2244 # this moves pixels to a new location in the returned image.
2245 # NOTE - should make a utility function to check transforms for
2246 # stack overruns
2247
2248 sub transform {
2249   my $self=shift;
2250   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2251   my %opts=@_;
2252   my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2253
2254 #  print Dumper(\%opts);
2255 #  xopcopdes
2256
2257   if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2258     if (!$I2P) {
2259       eval ("use Affix::Infix2Postfix;");
2260       print $@;
2261       if ( $@ ) {
2262         $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2263         return undef;
2264       }
2265       $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2266                                              {op=>'-',trans=>'Sub'},
2267                                              {op=>'*',trans=>'Mult'},
2268                                              {op=>'/',trans=>'Div'},
2269                                              {op=>'-','type'=>'unary',trans=>'u-'},
2270                                              {op=>'**'},
2271                                              {op=>'func','type'=>'unary'}],
2272                                      'grouping'=>[qw( \( \) )],
2273                                      'func'=>[qw( sin cos )],
2274                                      'vars'=>[qw( x y )]
2275                                     );
2276     }
2277
2278     @xt=$I2P->translate($opts{'xexpr'});
2279     @yt=$I2P->translate($opts{'yexpr'});
2280
2281     $numre=$I2P->{'numre'};
2282     @pt=(0,0);
2283
2284     for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2285     for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2286     @{$opts{'parm'}}=@pt;
2287   }
2288
2289 #  print Dumper(\%opts);
2290
2291   if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2292     $self->{ERRSTR}='transform: no xopcodes given.';
2293     return undef;
2294   }
2295
2296   @op=@{$opts{'xopcodes'}};
2297   for $iop (@op) {
2298     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2299       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2300       return undef;
2301     }
2302     push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2303   }
2304
2305
2306 # yopcopdes
2307
2308   if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2309     $self->{ERRSTR}='transform: no yopcodes given.';
2310     return undef;
2311   }
2312
2313   @op=@{$opts{'yopcodes'}};
2314   for $iop (@op) {
2315     if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2316       $self->{ERRSTR}="transform: illegal opcode '$_'.";
2317       return undef;
2318     }
2319     push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2320   }
2321
2322 #parameters
2323
2324   if ( !exists $opts{'parm'}) {
2325     $self->{ERRSTR}='transform: no parameter arg given.';
2326     return undef;
2327   }
2328
2329 #  print Dumper(\@ropx);
2330 #  print Dumper(\@ropy);
2331 #  print Dumper(\@ropy);
2332
2333   my $img = Imager->new();
2334   $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2335   if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2336   return $img;
2337 }
2338
2339
2340 sub transform2 {
2341   my ($opts, @imgs) = @_;
2342
2343   require "Imager/Expr.pm";
2344
2345   $opts->{variables} = [ qw(x y) ];
2346   my ($width, $height) = @{$opts}{qw(width height)};
2347   if (@imgs) {
2348     $width ||= $imgs[0]->getwidth();
2349     $height ||= $imgs[0]->getheight();
2350     my $img_num = 1;
2351     for my $img (@imgs) {
2352       $opts->{constants}{"w$img_num"} = $img->getwidth();
2353       $opts->{constants}{"h$img_num"} = $img->getheight();
2354       $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2355       $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2356       ++$img_num;
2357     }
2358   }
2359   if ($width) {
2360     $opts->{constants}{w} = $width;
2361     $opts->{constants}{cx} = $width/2;
2362   }
2363   else {
2364     $Imager::ERRSTR = "No width supplied";
2365     return;
2366   }
2367   if ($height) {
2368     $opts->{constants}{h} = $height;
2369     $opts->{constants}{cy} = $height/2;
2370   }
2371   else {
2372     $Imager::ERRSTR = "No height supplied";
2373     return;
2374   }
2375   my $code = Imager::Expr->new($opts);
2376   if (!$code) {
2377     $Imager::ERRSTR = Imager::Expr::error();
2378     return;
2379   }
2380   my $channels = $opts->{channels} || 3;
2381   unless ($channels >= 1 && $channels <= 4) {
2382     return Imager->_set_error("channels must be an integer between 1 and 4");
2383   }
2384
2385   my $img = Imager->new();
2386   $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2387                              $channels, $code->code(),
2388                              $code->nregs(), $code->cregs(),
2389                              [ map { $_->{IMG} } @imgs ]);
2390   if (!defined $img->{IMG}) {
2391     $Imager::ERRSTR = Imager->_error_as_msg();
2392     return;
2393   }
2394
2395   return $img;
2396 }
2397
2398 sub rubthrough {
2399   my $self=shift;
2400   my %opts= @_;
2401
2402   unless ($self->{IMG}) {
2403     $self->{ERRSTR}='empty input image';
2404     return undef;
2405   }
2406   unless ($opts{src} && $opts{src}->{IMG}) {
2407     $self->{ERRSTR}='empty input image for src';
2408     return undef;
2409   }
2410
2411   %opts = (src_minx => 0,
2412            src_miny => 0,
2413            src_maxx => $opts{src}->getwidth(),
2414            src_maxy => $opts{src}->getheight(),
2415            %opts);
2416
2417   my $tx = $opts{tx};
2418   defined $tx or $tx = $opts{left};
2419   defined $tx or $tx = 0;
2420
2421   my $ty = $opts{ty};
2422   defined $ty or $ty = $opts{top};
2423   defined $ty or $ty = 0;
2424
2425   unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
2426                     $opts{src_minx}, $opts{src_miny},
2427                     $opts{src_maxx}, $opts{src_maxy})) {
2428     $self->_set_error($self->_error_as_msg());
2429     return undef;
2430   }
2431
2432   return $self;
2433 }
2434
2435 sub compose {
2436   my $self = shift;
2437   my %opts =
2438     (
2439      opacity => 1.0,
2440      mask_left => 0,
2441      mask_top => 0,
2442      @_
2443     );
2444
2445   unless ($self->{IMG}) {
2446     $self->_set_error("compose: empty input image");
2447     return;
2448   }
2449
2450   unless ($opts{src}) {
2451     $self->_set_error("compose: src parameter missing");
2452     return;
2453   }
2454
2455   unless ($opts{src}{IMG}) {
2456     $self->_set_error("compose: src parameter empty image");
2457     return;
2458   }
2459   my $src = $opts{src};
2460
2461   my $left = $opts{left};
2462   defined $left or $left = $opts{tx};
2463   defined $left or $left = 0;
2464
2465   my $top = $opts{top};
2466   defined $top or $top = $opts{ty};
2467   defined $top or $top = 0;
2468
2469   my $src_left = $opts{src_left};
2470   defined $src_left or $src_left = $opts{src_minx};
2471   defined $src_left or $src_left = 0;
2472
2473   my $src_top = $opts{src_top};
2474   defined $src_top or $src_top = $opts{src_miny};
2475   defined $src_top or $src_top = 0;
2476
2477   my $width = $opts{width};
2478   if (!defined $width && defined $opts{src_maxx}) {
2479     $width = $opts{src_maxx} - $src_left;
2480   }
2481   defined $width or $width = $src->getwidth() - $src_left;
2482
2483   my $height = $opts{height};
2484   if (!defined $height && defined $opts{src_maxy}) {
2485     $height = $opts{src_maxy} - $src_top;
2486   }
2487   defined $height or $height = $src->getheight() - $src_top;
2488
2489   my $combine = $self->_combine($opts{combine}, 'normal');
2490
2491   if ($opts{mask}) {
2492     unless ($opts{mask}{IMG}) {
2493       $self->_set_error("compose: mask parameter empty image");
2494       return;
2495     }
2496
2497     my $mask_left = $opts{mask_left};
2498     defined $mask_left or $mask_left = $opts{mask_minx};
2499     defined $mask_left or $mask_left = 0;
2500
2501     my $mask_top = $opts{mask_top};
2502     defined $mask_top or $mask_top = $opts{mask_miny};
2503     defined $mask_top or $mask_top = 0;
2504
2505     i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
2506                    $left, $top, $src_left, $src_top,
2507                    $mask_left, $mask_top, $width, $height,
2508                    $combine, $opts{opacity})
2509       or return;
2510   }
2511   else {
2512     i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2513               $width, $height, $combine, $opts{opacity})
2514       or return;
2515   }
2516
2517   return $self;
2518 }
2519
2520 sub flip {
2521   my $self  = shift;
2522   my %opts  = @_;
2523   my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
2524   my $dir;
2525   return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2526   $dir = $xlate{$opts{'dir'}};
2527   return $self if i_flipxy($self->{IMG}, $dir);
2528   return ();
2529 }
2530
2531 sub rotate {
2532   my $self = shift;
2533   my %opts = @_;
2534
2535   unless (defined wantarray) {
2536     my @caller = caller;
2537     warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2538     return;
2539   }
2540
2541   if (defined $opts{right}) {
2542     my $degrees = $opts{right};
2543     if ($degrees < 0) {
2544       $degrees += 360 * int(((-$degrees)+360)/360);
2545     }
2546     $degrees = $degrees % 360;
2547     if ($degrees == 0) {
2548       return $self->copy();
2549     }
2550     elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2551       my $result = Imager->new();
2552       if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2553         return $result;
2554       }
2555       else {
2556         $self->{ERRSTR} = $self->_error_as_msg();
2557         return undef;
2558       }
2559     }
2560     else {
2561       $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2562       return undef;
2563     }
2564   }
2565   elsif (defined $opts{radians} || defined $opts{degrees}) {
2566     my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2567
2568     my $back = $opts{back};
2569     my $result = Imager->new;
2570     if ($back) {
2571       $back = _color($back);
2572       unless ($back) {
2573         $self->_set_error(Imager->errstr);
2574         return undef;
2575       }
2576
2577       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
2578     }
2579     else {
2580       $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2581     }
2582     if ($result->{IMG}) {
2583       return $result;
2584     }
2585     else {
2586       $self->{ERRSTR} = $self->_error_as_msg();
2587       return undef;
2588     }
2589   }
2590   else {
2591     $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
2592     return undef;
2593   }
2594 }
2595
2596 sub matrix_transform {
2597   my $self = shift;
2598   my %opts = @_;
2599
2600   unless (defined wantarray) {
2601     my @caller = caller;
2602     warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2603     return;
2604   }
2605
2606   if ($opts{matrix}) {
2607     my $xsize = $opts{xsize} || $self->getwidth;
2608     my $ysize = $opts{ysize} || $self->getheight;
2609
2610     my $result = Imager->new;
2611     if ($opts{back}) {
2612       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2613                                           $opts{matrix}, $opts{back})
2614         or return undef;
2615     }
2616     else {
2617       $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2618                                           $opts{matrix})
2619         or return undef;
2620     }
2621
2622     return $result;
2623   }
2624   else {
2625     $self->{ERRSTR} = "matrix parameter required";
2626     return undef;
2627   }
2628 }
2629
2630 # blame Leolo :)
2631 *yatf = \&matrix_transform;
2632
2633 # These two are supported for legacy code only
2634
2635 sub i_color_new {
2636   return Imager::Color->new(@_);
2637 }
2638
2639 sub i_color_set {
2640   return Imager::Color::set(@_);
2641 }
2642
2643 # Draws a box between the specified corner points.
2644 sub box {
2645   my $self=shift;
2646   my $raw = $self->{IMG};
2647
2648   unless ($raw) {
2649     $self->{ERRSTR}='empty input image';
2650     return undef;
2651   }
2652
2653   my %opts = @_;
2654
2655   my ($xmin, $ymin, $xmax, $ymax);
2656   if (exists $opts{'box'}) {
2657     $xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2658     $xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2659     $ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2660     $ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2661   }
2662   else {
2663     defined($xmin = $opts{xmin}) or $xmin = 0;
2664     defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
2665     defined($ymin = $opts{ymin}) or $ymin = 0;
2666     defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
2667   }
2668
2669   if ($opts{filled}) {
2670     my $color = $opts{'color'};
2671
2672     if (defined $color) {
2673       unless (_is_color_object($color)) {
2674         $color = _color($color);
2675         unless ($color) {
2676           $self->{ERRSTR} = $Imager::ERRSTR;
2677           return;
2678         }
2679       }
2680     }
2681     else {
2682       $color = i_color_new(255,255,255,255);
2683     }
2684
2685     i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
2686   }
2687   elsif ($opts{fill}) {
2688     unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2689       # assume it's a hash ref
2690       require 'Imager/Fill.pm';
2691       unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2692         $self->{ERRSTR} = $Imager::ERRSTR;
2693         return undef;
2694       }
2695     }
2696     i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
2697   }
2698   else {
2699     my $color = $opts{'color'};
2700     if (defined $color) {
2701       unless (_is_color_object($color)) {
2702         $color = _color($color);
2703         unless ($color) {
2704           $self->{ERRSTR} = $Imager::ERRSTR;
2705           return;
2706         }
2707       }
2708     }
2709     else {
2710       $color = i_color_new(255, 255, 255, 255);
2711     }
2712     unless ($color) {
2713       $self->{ERRSTR} = $Imager::ERRSTR;
2714       return;
2715     }
2716     i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
2717   }
2718
2719   return $self;
2720 }
2721
2722 sub arc {
2723   my $self=shift;
2724   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2725   my $dflcl= [ 255, 255, 255, 255];
2726   my $good = 1;
2727   my %opts=
2728     (
2729      color=>$dflcl,
2730      'r'=>_min($self->getwidth(),$self->getheight())/3,
2731      'x'=>$self->getwidth()/2,
2732      'y'=>$self->getheight()/2,
2733      'd1'=>0, 'd2'=>361,
2734      filled => 1,
2735      @_,
2736     );
2737   if ($opts{aa}) {
2738     if ($opts{fill}) {
2739       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2740         # assume it's a hash ref
2741         require 'Imager/Fill.pm';
2742         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2743           $self->{ERRSTR} = $Imager::ERRSTR;
2744           return;
2745         }
2746       }
2747       i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2748                      $opts{'d2'}, $opts{fill}{fill});
2749     }
2750     elsif ($opts{filled}) {
2751       my $color = _color($opts{'color'});
2752       unless ($color) {
2753         $self->{ERRSTR} = $Imager::ERRSTR;
2754         return;
2755       }
2756       if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2757         i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2758                     $color);
2759       }
2760       else {
2761         i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2762                  $opts{'d1'}, $opts{'d2'}, $color);
2763       }
2764     }
2765     else {
2766       my $color = _color($opts{'color'});
2767       if ($opts{d2} - $opts{d1} >= 360) {
2768         $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2769       }
2770       else {
2771         $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2772       }
2773     }
2774   }
2775   else {
2776     if ($opts{fill}) {
2777       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2778         # assume it's a hash ref
2779         require 'Imager/Fill.pm';
2780         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2781           $self->{ERRSTR} = $Imager::ERRSTR;
2782           return;
2783         }
2784       }
2785       i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2786                   $opts{'d2'}, $opts{fill}{fill});
2787     }
2788     else {
2789       my $color = _color($opts{'color'});
2790       unless ($color) {
2791         $self->{ERRSTR} = $Imager::ERRSTR;
2792         return;
2793       }
2794       if ($opts{filled}) {
2795         i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2796               $opts{'d1'}, $opts{'d2'}, $color);
2797       }
2798       else {
2799         if ($opts{d1} == 0 && $opts{d2} == 361) {
2800           $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2801         }
2802         else {
2803           $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2804         }
2805       }
2806     }
2807   }
2808   unless ($good) {
2809     $self->_set_error($self->_error_as_msg);
2810     return;
2811   }
2812
2813   return $self;
2814 }
2815
2816 # Draws a line from one point to the other
2817 # the endpoint is set if the endp parameter is set which it is by default.
2818 # to turn of the endpoint being set use endp=>0 when calling line.
2819
2820 sub line {
2821   my $self=shift;
2822   my $dflcl=i_color_new(0,0,0,0);
2823   my %opts=(color=>$dflcl,
2824             endp => 1,
2825             @_);
2826   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2827
2828   unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2829   unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2830
2831   my $color = _color($opts{'color'});
2832   unless ($color) {
2833     $self->{ERRSTR} = $Imager::ERRSTR;
2834     return;
2835   }
2836
2837   $opts{antialias} = $opts{aa} if defined $opts{aa};
2838   if ($opts{antialias}) {
2839     i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2840               $color, $opts{endp});
2841   } else {
2842     i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2843            $color, $opts{endp});
2844   }
2845   return $self;
2846 }
2847
2848 # Draws a line between an ordered set of points - It more or less just transforms this
2849 # into a list of lines.
2850
2851 sub polyline {
2852   my $self=shift;
2853   my ($pt,$ls,@points);
2854   my $dflcl=i_color_new(0,0,0,0);
2855   my %opts=(color=>$dflcl,@_);
2856
2857   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2858
2859   if (exists($opts{points})) { @points=@{$opts{points}}; }
2860   if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2861     @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2862     }
2863
2864 #  print Dumper(\@points);
2865
2866   my $color = _color($opts{'color'});
2867   unless ($color) {
2868     $self->{ERRSTR} = $Imager::ERRSTR;
2869     return;
2870   }
2871   $opts{antialias} = $opts{aa} if defined $opts{aa};
2872   if ($opts{antialias}) {
2873     for $pt(@points) {
2874       if (defined($ls)) {
2875         i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
2876       }
2877       $ls=$pt;
2878     }
2879   } else {
2880     for $pt(@points) {
2881       if (defined($ls)) {
2882         i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
2883       }
2884       $ls=$pt;
2885     }
2886   }
2887   return $self;
2888 }
2889
2890 sub polygon {
2891   my $self = shift;
2892   my ($pt,$ls,@points);
2893   my $dflcl = i_color_new(0,0,0,0);
2894   my %opts = (color=>$dflcl, @_);
2895
2896   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2897
2898   if (exists($opts{points})) {
2899     $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2900     $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2901   }
2902
2903   if (!exists $opts{'x'} or !exists $opts{'y'})  {
2904     $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2905   }
2906
2907   if ($opts{'fill'}) {
2908     unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2909       # assume it's a hash ref
2910       require 'Imager/Fill.pm';
2911       unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2912         $self->{ERRSTR} = $Imager::ERRSTR;
2913         return undef;
2914       }
2915     }
2916     i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2917                     $opts{'fill'}{'fill'});
2918   }
2919   else {
2920     my $color = _color($opts{'color'});
2921     unless ($color) {
2922       $self->{ERRSTR} = $Imager::ERRSTR;
2923       return;
2924     }
2925     i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
2926   }
2927
2928   return $self;
2929 }
2930
2931
2932 # this the multipoint bezier curve
2933 # this is here more for testing that actual usage since
2934 # this is not a good algorithm.  Usually the curve would be
2935 # broken into smaller segments and each done individually.
2936
2937 sub polybezier {
2938   my $self=shift;
2939   my ($pt,$ls,@points);
2940   my $dflcl=i_color_new(0,0,0,0);
2941   my %opts=(color=>$dflcl,@_);
2942
2943   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2944
2945   if (exists $opts{points}) {
2946     $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2947     $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2948   }
2949
2950   unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2951     $self->{ERRSTR}='Missing or invalid points.';
2952     return;
2953   }
2954
2955   my $color = _color($opts{'color'});
2956   unless ($color) {
2957     $self->{ERRSTR} = $Imager::ERRSTR;
2958     return;
2959   }
2960   i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
2961   return $self;
2962 }
2963
2964 sub flood_fill {
2965   my $self = shift;
2966   my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
2967   my $rc;
2968
2969   unless (exists $opts{'x'} && exists $opts{'y'}) {
2970     $self->{ERRSTR} = "missing seed x and y parameters";
2971     return undef;
2972   }
2973
2974   if ($opts{border}) {
2975     my $border = _color($opts{border});
2976     unless ($border) {
2977       $self->_set_error($Imager::ERRSTR);
2978       return;
2979     }
2980     if ($opts{fill}) {
2981       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2982         # assume it's a hash ref
2983         require Imager::Fill;
2984         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2985           $self->{ERRSTR} = $Imager::ERRSTR;
2986           return;
2987         }
2988       }
2989       $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2990                                  $opts{fill}{fill}, $border);
2991     }
2992     else {
2993       my $color = _color($opts{'color'});
2994       unless ($color) {
2995         $self->{ERRSTR} = $Imager::ERRSTR;
2996         return;
2997       }
2998       $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
2999                                 $color, $border);
3000     }
3001     if ($rc) {
3002       return $self;
3003     }
3004     else {
3005       $self->{ERRSTR} = $self->_error_as_msg();
3006       return;
3007     }
3008   }
3009   else {
3010     if ($opts{fill}) {
3011       unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3012         # assume it's a hash ref
3013         require 'Imager/Fill.pm';
3014         unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3015           $self->{ERRSTR} = $Imager::ERRSTR;
3016           return;
3017         }
3018       }
3019       $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3020     }
3021     else {
3022       my $color = _color($opts{'color'});
3023       unless ($color) {
3024         $self->{ERRSTR} = $Imager::ERRSTR;
3025         return;
3026       }
3027       $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3028     }
3029     if ($rc) {
3030       return $self;
3031     }
3032     else {
3033       $self->{ERRSTR} = $self->_error_as_msg();
3034       return;
3035     }
3036   }
3037 }
3038
3039 sub setpixel {
3040   my ($self, %opts) = @_;
3041
3042   my $color = $opts{color};
3043   unless (defined $color) {
3044     $color = $self->{fg};
3045     defined $color or $color = NC(255, 255, 255);
3046   }
3047
3048   unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3049     $color = _color($color)
3050       or return undef;
3051   }
3052
3053   unless (exists $opts{'x'} && exists $opts{'y'}) {
3054     $self->{ERRSTR} = 'missing x and y parameters';
3055     return undef;
3056   }
3057
3058   my $x = $opts{'x'};
3059   my $y = $opts{'y'};
3060   if (ref $x && ref $y) {
3061     unless (@$x == @$y) {
3062       $self->{ERRSTR} = 'length of x and y mismatch';
3063       return;
3064     }
3065     my $set = 0;
3066     if ($color->isa('Imager::Color')) {
3067       for my $i (0..$#{$opts{'x'}}) {
3068         i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3069           or ++$set;
3070       }
3071     }
3072     else {
3073       for my $i (0..$#{$opts{'x'}}) {
3074         i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3075           or ++$set;
3076       }
3077     }
3078     $set or return;
3079     return $set;
3080   }
3081   else {
3082     if ($color->isa('Imager::Color')) {
3083       i_ppix($self->{IMG}, $x, $y, $color)
3084         and return;
3085     }
3086     else {
3087       i_ppixf($self->{IMG}, $x, $y, $color)
3088         and return;
3089     }
3090   }
3091
3092   $self;
3093 }
3094
3095 sub getpixel {
3096   my $self = shift;
3097
3098   my %opts = ( "type"=>'8bit', @_);
3099
3100   unless (exists $opts{'x'} && exists $opts{'y'}) {
3101     $self->{ERRSTR} = 'missing x and y parameters';
3102     return undef;
3103   }
3104
3105   my $x = $opts{'x'};
3106   my $y = $opts{'y'};
3107   if (ref $x && ref $y) {
3108     unless (@$x == @$y) {
3109       $self->{ERRSTR} = 'length of x and y mismatch';
3110       return undef;
3111     }
3112     my @result;
3113     if ($opts{"type"} eq '8bit') {
3114       for my $i (0..$#{$opts{'x'}}) {
3115         push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3116       }
3117     }
3118     else {
3119       for my $i (0..$#{$opts{'x'}}) {
3120         push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3121       }
3122     }
3123     return wantarray ? @result : \@result;
3124   }
3125   else {
3126     if ($opts{"type"} eq '8bit') {
3127       return i_get_pixel($self->{IMG}, $x, $y);
3128     }
3129     else {
3130       return i_gpixf($self->{IMG}, $x, $y);
3131     }
3132   }
3133
3134   $self;
3135 }
3136
3137 sub getscanline {
3138   my $self = shift;
3139   my %opts = ( type => '8bit', x=>0, @_);
3140
3141   $self->_valid_image or return;
3142
3143   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3144
3145   unless (defined $opts{'y'}) {
3146     $self->_set_error("missing y parameter");
3147     return;
3148   }
3149
3150   if ($opts{type} eq '8bit') {
3151     return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3152                   $opts{'y'});
3153   }
3154   elsif ($opts{type} eq 'float') {
3155     return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3156                   $opts{'y'});
3157   }
3158   elsif ($opts{type} eq 'index') {
3159     unless (i_img_type($self->{IMG})) {
3160       $self->_set_error("type => index only valid on paletted images");
3161       return;
3162     }
3163     return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3164                   $opts{'y'});
3165   }
3166   else {
3167     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3168     return;
3169   }
3170 }
3171
3172 sub setscanline {
3173   my $self = shift;
3174   my %opts = ( x=>0, @_);
3175
3176   $self->_valid_image or return;
3177
3178   unless (defined $opts{'y'}) {
3179     $self->_set_error("missing y parameter");
3180     return;
3181   }
3182
3183   if (!$opts{type}) {
3184     if (ref $opts{pixels} && @{$opts{pixels}}) {
3185       # try to guess the type
3186       if ($opts{pixels}[0]->isa('Imager::Color')) {
3187         $opts{type} = '8bit';
3188       }
3189       elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3190         $opts{type} = 'float';
3191       }
3192       else {
3193         $self->_set_error("missing type parameter and could not guess from pixels");
3194         return;
3195       }
3196     }
3197     else {
3198       # default
3199       $opts{type} = '8bit';
3200     }
3201   }
3202
3203   if ($opts{type} eq '8bit') {
3204     if (ref $opts{pixels}) {
3205       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3206     }
3207     else {
3208       return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3209     }
3210   }
3211   elsif ($opts{type} eq 'float') {
3212     if (ref $opts{pixels}) {
3213       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3214     }
3215     else {
3216       return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3217     }
3218   }
3219   elsif ($opts{type} eq 'index') {
3220     if (ref $opts{pixels}) {
3221       return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3222     }
3223     else {
3224       return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3225     }
3226   }
3227   else {
3228     $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3229     return;
3230   }
3231 }
3232
3233 sub getsamples {
3234   my $self = shift;
3235   my %opts = ( type => '8bit', x=>0, offset => 0, @_);
3236
3237   defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3238
3239   unless (defined $opts{'y'}) {
3240     $self->_set_error("missing y parameter");
3241     return;
3242   }
3243
3244   unless ($opts{channels}) {
3245     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3246   }
3247
3248   if ($opts{target}) {
3249     my $target = $opts{target};
3250     my $offset = $opts{offset};
3251     if ($opts{type} eq '8bit') {
3252       my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3253                             $opts{y}, @{$opts{channels}})
3254         or return;
3255       @{$target}{$offset .. $offset + @samples - 1} = @samples;
3256       return scalar(@samples);
3257     }
3258     elsif ($opts{type} eq 'float') {
3259       my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3260                              $opts{y}, @{$opts{channels}});
3261       @{$target}{$offset .. $offset + @samples - 1} = @samples;
3262       return scalar(@samples);
3263     }
3264     elsif ($opts{type} =~ /^(\d+)bit$/) {
3265       my $bits = $1;
3266
3267       my @data;
3268       my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3269                                $opts{y}, $bits, $target,
3270                                $offset, @{$opts{channels}});
3271       unless (defined $count) {
3272         $self->_set_error(Imager->_error_as_msg);
3273         return;
3274       }
3275
3276       return $count;
3277     }
3278     else {
3279       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3280       return;
3281     }
3282   }
3283   else {
3284     if ($opts{type} eq '8bit') {
3285       return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3286                      $opts{y}, @{$opts{channels}});
3287     }
3288     elsif ($opts{type} eq 'float') {
3289       return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3290                       $opts{y}, @{$opts{channels}});
3291     }
3292     elsif ($opts{type} =~ /^(\d+)bit$/) {
3293       my $bits = $1;
3294
3295       my @data;
3296       i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3297                    $opts{y}, $bits, \@data, 0, @{$opts{channels}})
3298         or return;
3299       return @data;
3300     }
3301     else {
3302       $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3303       return;
3304     }
3305   }
3306 }
3307
3308 sub setsamples {
3309   my $self = shift;
3310   my %opts = ( x => 0, offset => 0, @_ );
3311
3312   unless ($self->{IMG}) {
3313     $self->_set_error('setsamples: empty input image');
3314     return;
3315   }
3316
3317   unless(defined $opts{data} && ref $opts{data}) {
3318     $self->_set_error('setsamples: data parameter missing or invalid');
3319     return;
3320   }
3321
3322   unless ($opts{channels}) {
3323     $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3324   }
3325
3326   unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) {
3327     $self->_set_error('setsamples: type parameter missing or invalid');
3328     return;
3329   }
3330   my $bits = $1;
3331
3332   unless (defined $opts{width}) {
3333     $opts{width} = $self->getwidth() - $opts{x};
3334   }
3335
3336   my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3337                            $opts{channels}, $opts{data}, $opts{offset},
3338                            $opts{width});
3339   unless (defined $count) {
3340     $self->_set_error(Imager->_error_as_msg);
3341     return;
3342   }
3343
3344   return $count;
3345 }
3346
3347 # make an identity matrix of the given size
3348 sub _identity {
3349   my ($size) = @_;
3350
3351   my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3352   for my $c (0 .. ($size-1)) {
3353     $matrix->[$c][$c] = 1;
3354   }
3355   return $matrix;
3356 }
3357
3358 # general function to convert an image
3359 sub convert {
3360   my ($self, %opts) = @_;
3361   my $matrix;
3362
3363   unless (defined wantarray) {
3364     my @caller = caller;
3365     warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3366     return;
3367   }
3368
3369   # the user can either specify a matrix or preset
3370   # the matrix overrides the preset
3371   if (!exists($opts{matrix})) {
3372     unless (exists($opts{preset})) {
3373       $self->{ERRSTR} = "convert() needs a matrix or preset";
3374       return;
3375     }
3376     else {
3377       if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3378         # convert to greyscale, keeping the alpha channel if any
3379         if ($self->getchannels == 3) {
3380           $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3381         }
3382         elsif ($self->getchannels == 4) {
3383           # preserve the alpha channel
3384           $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3385                       [ 0,     0,     0,     1 ] ];
3386         }
3387         else {
3388           # an identity
3389           $matrix = _identity($self->getchannels);
3390         }
3391       }
3392       elsif ($opts{preset} eq 'noalpha') {
3393         # strip the alpha channel
3394         if ($self->getchannels == 2 or $self->getchannels == 4) {
3395           $matrix = _identity($self->getchannels);
3396           pop(@$matrix); # lose the alpha entry
3397         }
3398         else {
3399           $matrix = _identity($self->getchannels);
3400         }
3401       }
3402       elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3403         # extract channel 0
3404         $matrix = [ [ 1 ] ];
3405       }
3406       elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3407         $matrix = [ [ 0, 1 ] ];
3408       }
3409       elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3410         $matrix = [ [ 0, 0, 1 ] ];
3411       }
3412       elsif ($opts{preset} eq 'alpha') {
3413         if ($self->getchannels == 2 or $self->getchannels == 4) {
3414           $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3415         }
3416         else {
3417           # the alpha is just 1 <shrug>
3418           $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3419         }
3420       }
3421       elsif ($opts{preset} eq 'rgb') {
3422         if ($self->getchannels == 1) {
3423           $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3424         }
3425         elsif ($self->getchannels == 2) {
3426           # preserve the alpha channel
3427           $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3428         }
3429         else {
3430           $matrix = _identity($self->getchannels);
3431         }
3432       }
3433       elsif ($opts{preset} eq 'addalpha') {
3434         if ($self->getchannels == 1) {
3435           $matrix = _identity(2);
3436         }
3437         elsif ($self->getchannels == 3) {
3438           $matrix = _identity(4);
3439         }
3440         else {
3441           $matrix = _identity($self->getchannels);
3442         }
3443       }
3444       else {
3445         $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3446         return undef;
3447       }
3448     }
3449   }
3450   else {
3451     $matrix = $opts{matrix};
3452   }
3453
3454   my $new = Imager->new;
3455   $new->{IMG} = i_convert($self->{IMG}, $matrix);
3456   unless ($new->{IMG}) {
3457     # most likely a bad matrix
3458     $self->{ERRSTR} = _error_as_msg();
3459     return undef;
3460   }
3461   return $new;
3462 }
3463
3464 # combine channels from multiple input images, a class method
3465 sub combine {
3466   my ($class, %opts) = @_;
3467
3468   my $src = delete $opts{src};
3469   unless ($src) {
3470     $class->_set_error("src parameter missing");
3471     return;
3472   }
3473   my @imgs;
3474   my $index = 0;
3475   for my $img (@$src) {
3476     unless (eval { $img->isa("Imager") }) {
3477       $class->_set_error("src must contain image objects");
3478       return;
3479     }
3480     unless ($img->{IMG}) {
3481       $class->_set_error("empty input image");
3482       return;
3483     }
3484     push @imgs, $img->{IMG};
3485   }
3486   my $result;
3487   if (my $channels = delete $opts{channels}) {
3488     $result = i_combine(\@imgs, $channels);
3489   }
3490   else {
3491     $result = i_combine(\@imgs);
3492   }
3493   unless ($result) {
3494     $class->_set_error($class->_error_as_msg);
3495     return;
3496   }
3497
3498   my $img = $class->new;
3499   $img->{IMG} = $result;
3500
3501   return $img;
3502 }
3503
3504
3505 # general function to map an image through lookup tables
3506
3507 sub map {
3508   my ($self, %opts) = @_;
3509   my @chlist = qw( red green blue alpha );
3510
3511   if (!exists($opts{'maps'})) {
3512     # make maps from channel maps
3513     my $chnum;
3514     for $chnum (0..$#chlist) {
3515       if (exists $opts{$chlist[$chnum]}) {
3516         $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3517       } elsif (exists $opts{'all'}) {
3518         $opts{'maps'}[$chnum] = $opts{'all'};
3519       }
3520     }
3521   }
3522   if ($opts{'maps'} and $self->{IMG}) {
3523     i_map($self->{IMG}, $opts{'maps'} );
3524   }
3525   return $self;
3526 }
3527
3528 sub difference {
3529   my ($self, %opts) = @_;
3530
3531   defined $opts{mindist} or $opts{mindist} = 0;
3532
3533   defined $opts{other}
3534     or return $self->_set_error("No 'other' parameter supplied");
3535   defined $opts{other}{IMG}
3536     or return $self->_set_error("No image data in 'other' image");
3537
3538   $self->{IMG}
3539     or return $self->_set_error("No image data");
3540
3541   my $result = Imager->new;
3542   $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3543                                 $opts{mindist})
3544     or return $self->_set_error($self->_error_as_msg());
3545
3546   return $result;
3547 }
3548
3549 # destructive border - image is shrunk by one pixel all around
3550
3551 sub border {
3552   my ($self,%opts)=@_;
3553   my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3554   $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3555 }
3556
3557
3558 # Get the width of an image
3559
3560 sub getwidth {
3561   my $self = shift;
3562
3563   if (my $raw = $self->{IMG}) {
3564     return i_img_get_width($raw);
3565   }
3566   else {
3567     $self->{ERRSTR} = 'image is empty'; return undef;
3568   }
3569 }
3570
3571 # Get the height of an image
3572
3573 sub getheight {
3574   my $self = shift;
3575
3576   if (my $raw = $self->{IMG}) {
3577     return i_img_get_height($raw);
3578   }
3579   else {
3580     $self->{ERRSTR} = 'image is empty'; return undef;
3581   }
3582 }
3583
3584 # Get number of channels in an image
3585
3586 sub getchannels {
3587   my $self = shift;
3588   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3589   return i_img_getchannels($self->{IMG});
3590 }
3591
3592 # Get channel mask
3593
3594 sub getmask {
3595   my $self = shift;
3596   if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3597   return i_img_getmask($self->{IMG});
3598 }
3599
3600 # Set channel mask
3601
3602 sub setmask {
3603   my $self = shift;
3604   my %opts = @_;
3605   if (!defined($self->{IMG})) {
3606     $self->{ERRSTR} = 'image is empty';
3607     return undef;
3608   }
3609   unless (defined $opts{mask}) {
3610     $self->_set_error("mask parameter required");
3611     return;
3612   }
3613   i_img_setmask( $self->{IMG} , $opts{mask} );
3614
3615   1;
3616 }
3617
3618 # Get number of colors in an image
3619
3620 sub getcolorcount {
3621   my $self=shift;
3622   my %opts=('maxcolors'=>2**30,@_);
3623   if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3624   my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3625   return ($rc==-1? undef : $rc);
3626 }
3627
3628 # Returns a reference to a hash. The keys are colour named (packed) and the
3629 # values are the number of pixels in this colour.
3630 sub getcolorusagehash {
3631   my $self = shift;
3632
3633   my %opts = ( maxcolors => 2**30, @_ );
3634   my $max_colors = $opts{maxcolors};
3635   unless (defined $max_colors && $max_colors > 0) {
3636     $self->_set_error('maxcolors must be a positive integer');
3637     return;
3638   }
3639
3640   unless (defined $self->{IMG}) {
3641     $self->_set_error('empty input image');
3642     return;
3643   }
3644
3645   my $channels= $self->getchannels;
3646   # We don't want to look at the alpha channel, because some gifs using it
3647   # doesn't define it for every colour (but only for some)
3648   $channels -= 1 if $channels == 2 or $channels == 4;
3649   my %color_use;
3650   my $height = $self->getheight;
3651   for my $y (0 .. $height - 1) {
3652     my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3653     while (length $colors) {
3654       $color_use{ substr($colors, 0, $channels, '') }++;
3655     }
3656     keys %color_use > $max_colors
3657       and return;
3658   }
3659   return \%color_use;
3660 }
3661
3662 # This will return a ordered array of the colour usage. Kind of the sorted
3663 # version of the values of the hash returned by getcolorusagehash.
3664 # You might want to add safety checks and change the names, etc...
3665 sub getcolorusage {
3666   my $self = shift;
3667
3668   my %opts = ( maxcolors => 2**30, @_ );
3669   my $max_colors = $opts{maxcolors};
3670   unless (defined $max_colors && $max_colors > 0) {
3671     $self->_set_error('maxcolors must be a positive integer');
3672     return;
3673   }
3674
3675   unless (defined $self->{IMG}) {
3676     $self->_set_error('empty input image');
3677     return undef;
3678   }
3679
3680   return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
3681 }
3682
3683 # draw string to an image
3684
3685 sub string {
3686   my $self = shift;
3687   unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3688
3689   my %input=('x'=>0, 'y'=>0, @_);
3690   defined($input{string}) or $input{string} = $input{text};
3691
3692   unless(defined $input{string}) {
3693     $self->{ERRSTR}="missing required parameter 'string'";
3694     return;
3695   }
3696
3697   unless($input{font}) {
3698     $self->{ERRSTR}="missing required parameter 'font'";
3699     return;
3700   }
3701
3702   unless ($input{font}->draw(image=>$self, %input)) {
3703     return;
3704   }
3705
3706   return $self;
3707 }
3708
3709 sub align_string {
3710   my $self = shift;
3711
3712   my $img;
3713   if (ref $self) {
3714     unless ($self->{IMG}) {
3715       $self->{ERRSTR}='empty input image';
3716       return;
3717     }
3718     $img = $self;
3719   }
3720   else {
3721     $img = undef;
3722   }
3723
3724   my %input=('x'=>0, 'y'=>0, @_);
3725   defined $input{string}
3726     or $input{string} = $input{text};
3727
3728   unless(exists $input{string}) {
3729     $self->_set_error("missing required parameter 'string'");
3730     return;
3731   }
3732
3733   unless($input{font}) {
3734     $self->_set_error("missing required parameter 'font'");
3735     return;
3736   }
3737
3738   my @result;
3739   unless (@result = $input{font}->align(image=>$img, %input)) {
3740     return;
3741   }
3742
3743   return wantarray ? @result : $result[0];
3744 }
3745
3746 my @file_limit_names = qw/width height bytes/;
3747
3748 sub set_file_limits {
3749   shift;
3750
3751   my %opts = @_;
3752   my %values;
3753
3754   if ($opts{reset}) {
3755     @values{@file_limit_names} = (0) x @file_limit_names;
3756   }
3757   else {
3758     @values{@file_limit_names} = i_get_image_file_limits();
3759   }
3760
3761   for my $key (keys %values) {
3762     defined $opts{$key} and $values{$key} = $opts{$key};
3763   }
3764
3765   i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3766 }
3767
3768 sub get_file_limits {
3769   i_get_image_file_limits();
3770 }
3771
3772 # Shortcuts that can be exported
3773
3774 sub newcolor { Imager::Color->new(@_); }
3775 sub newfont  { Imager::Font->new(@_); }
3776 sub NCF {
3777   require Imager::Color::Float;
3778   return Imager::Color::Float->new(@_);
3779 }
3780
3781 *NC=*newcolour=*newcolor;
3782 *NF=*newfont;
3783
3784 *open=\&read;
3785 *circle=\&arc;
3786
3787
3788 #### Utility routines
3789
3790 sub errstr {
3791   ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3792 }
3793
3794 sub _set_error {
3795   my ($self, $msg) = @_;
3796
3797   if (ref $self) {
3798     $self->{ERRSTR} = $msg;
3799   }
3800   else {
3801     $ERRSTR = $msg;
3802   }
3803   return;
3804 }
3805
3806 # Default guess for the type of an image from extension
3807
3808 sub def_guess_type {
3809   my $name=lc(shift);
3810   my $ext;
3811   $ext=($name =~ m/\.([^\.]+)$/)[0];
3812   return 'tiff' if ($ext =~ m/^tiff?$/);
3813   return 'jpeg' if ($ext =~ m/^jpe?g$/);
3814   return 'pnm'  if ($ext =~ m/^p[pgb]m$/);
3815   return 'png'  if ($ext eq "png");
3816   return 'bmp'  if ($ext eq "bmp" || $ext eq "dib");
3817   return 'tga'  if ($ext eq "tga");
3818   return 'sgi'  if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
3819   return 'gif'  if ($ext eq "gif");
3820   return 'raw'  if ($ext eq "raw");
3821   return lc $ext; # best guess
3822   return ();
3823 }
3824
3825 sub combines {
3826   return @combine_types;
3827 }
3828
3829 # get the minimum of a list
3830
3831 sub _min {
3832   my $mx=shift;
3833   for(@_) { if ($_<$mx) { $mx=$_; }}
3834   return $mx;
3835 }
3836
3837 # get the maximum of a list
3838
3839 sub _max {
3840   my $mx=shift;
3841   for(@_) { if ($_>$mx) { $mx=$_; }}
3842   return $mx;
3843 }
3844
3845 # string stuff for iptc headers
3846
3847 sub _clean {
3848   my($str)=$_[0];
3849   $str = substr($str,3);
3850   $str =~ s/[\n\r]//g;
3851   $str =~ s/\s+/ /g;
3852   $str =~ s/^\s//;
3853   $str =~ s/\s$//;
3854   return $str;
3855 }
3856
3857 # A little hack to parse iptc headers.
3858
3859 sub parseiptc {
3860   my $self=shift;
3861   my(@sar,$item,@ar);
3862   my($caption,$photogr,$headln,$credit);
3863
3864   my $str=$self->{IPTCRAW};
3865
3866   defined $str
3867     or return;
3868
3869   @ar=split(/8BIM/,$str);
3870
3871   my $i=0;
3872   foreach (@ar) {
3873     if (/^\004\004/) {
3874       @sar=split(/\034\002/);
3875       foreach $item (@sar) {
3876         if ($item =~ m/^x/) {
3877           $caption = _clean($item);
3878           $i++;
3879         }
3880         if ($item =~ m/^P/) {
3881           $photogr = _clean($item);
3882           $i++;
3883         }
3884         if ($item =~ m/^i/) {
3885           $headln = _clean($item);
3886           $i++;
3887         }
3888         if ($item =~ m/^n/) {
3889           $credit = _clean($item);
3890           $i++;
3891         }
3892       }
3893     }
3894   }
3895   return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3896 }
3897
3898 sub Inline {
3899   my ($lang) = @_;
3900
3901   $lang eq 'C'
3902     or die "Only C language supported";
3903
3904   require Imager::ExtUtils;
3905   return Imager::ExtUtils->inline_config;
3906 }
3907
3908 # threads shouldn't try to close raw Imager objects
3909 sub Imager::ImgRaw::CLONE_SKIP { 1 }
3910
3911 sub preload {
3912   # this serves two purposes:
3913   # - a class method to load the file support modules included with Image
3914   #   (or were included, once the library dependent modules are split out)
3915   # - something for Module::ScanDeps to analyze
3916   # https://rt.cpan.org/Ticket/Display.html?id=6566
3917   local $@;
3918   eval { require Imager::File::GIF };
3919   eval { require Imager::File::JPEG };
3920   eval { require Imager::File::PNG };
3921   eval { require Imager::File::SGI };
3922   eval { require Imager::File::TIFF };
3923   eval { require Imager::File::ICO };
3924   eval { require Imager::Font::W32 };
3925   eval { require Imager::Font::FT2 };
3926   eval { require Imager::Font::T1 };
3927 }
3928
3929 # backward compatibility for %formats
3930 package Imager::FORMATS;
3931 use strict;
3932 use constant IX_FORMATS => 0;
3933 use constant IX_LIST => 1;
3934 use constant IX_INDEX => 2;
3935 use constant IX_CLASSES => 3;
3936
3937 sub TIEHASH {
3938   my ($class, $formats, $classes) = @_;
3939
3940   return bless [ $formats, [ ], 0, $classes ], $class;
3941 }
3942
3943 sub _check {
3944   my ($self, $key) = @_;
3945
3946   (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
3947   my $value;
3948   if (eval { require $file; 1 }) {
3949     $value = 1;
3950   }
3951   else {
3952     $value = undef;
3953   }
3954   $self->[IX_FORMATS]{$key} = $value;
3955
3956   return $value;
3957 }
3958
3959 sub FETCH {
3960   my ($self, $key) = @_;
3961
3962   exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
3963
3964   $self->[IX_CLASSES]{$key} or return undef;
3965
3966   return $self->_check($key);
3967 }
3968
3969 sub STORE {
3970   die "%Imager::formats is not user monifiable";
3971 }
3972
3973 sub DELETE {
3974   die "%Imager::formats is not user monifiable";
3975 }
3976
3977 sub CLEAR {
3978   die "%Imager::formats is not user monifiable";
3979 }
3980
3981 sub EXISTS {
3982   my ($self, $key) = @_;
3983
3984   if (exists $self->[IX_FORMATS]{$key}) {
3985     my $value = $self->[IX_FORMATS]{$key}
3986       or return;
3987     return 1;
3988   }
3989
3990   $self->_check($key) or return 1==0;
3991
3992   return 1==1;
3993 }
3994
3995 sub FIRSTKEY {
3996   my ($self) = @_;
3997
3998   unless (@{$self->[IX_LIST]}) {
3999     # full populate it
4000     @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4001       keys %{$self->[IX_FORMATS]};
4002
4003     for my $key (keys %{$self->[IX_CLASSES]}) {
4004       $self->[IX_FORMATS]{$key} and next;
4005       $self->_check($key)
4006         and push @{$self->[IX_LIST]}, $key;
4007     }
4008   }
4009
4010   @{$self->[IX_LIST]} or return;
4011   $self->[IX_INDEX] = 1;
4012   return $self->[IX_LIST][0];
4013 }
4014
4015 sub NEXTKEY {
4016   my ($self) = @_;
4017
4018   $self->[IX_INDEX] < @{$self->[IX_LIST]}
4019     or return;
4020
4021   return $self->[IX_LIST][$self->[IX_INDEX]++];
4022 }
4023
4024 sub SCALAR {
4025   my ($self) = @_;
4026
4027   return scalar @{$self->[IX_LIST]};
4028 }
4029
4030 1;
4031 __END__
4032 # Below is the stub of documentation for your module. You better edit it!
4033
4034 =head1 NAME
4035
4036 Imager - Perl extension for Generating 24 bit Images
4037
4038 =head1 SYNOPSIS
4039
4040   # Thumbnail example
4041
4042   #!/usr/bin/perl -w
4043   use strict;
4044   use Imager;
4045
4046   die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
4047   my $file = shift;
4048
4049   my $format;
4050
4051   # see Imager::Files for information on the read() method
4052   my $img = Imager->new(file=>$file)
4053     or die Imager->errstr();
4054
4055   $file =~ s/\.[^.]*$//;
4056
4057   # Create smaller version
4058   # documented in Imager::Transformations
4059   my $thumb = $img->scale(scalefactor=>.3);
4060
4061   # Autostretch individual channels
4062   $thumb->filter(type=>'autolevels');
4063
4064   # try to save in one of these formats
4065   SAVE:
4066
4067   for $format ( qw( png gif jpeg tiff ppm ) ) {
4068     # Check if given format is supported
4069     if ($Imager::formats{$format}) {
4070       $file.="_low.$format";
4071       print "Storing image as: $file\n";
4072       # documented in Imager::Files
4073       $thumb->write(file=>$file) or
4074         die $thumb->errstr;
4075       last SAVE;
4076     }
4077   }
4078
4079 =head1 DESCRIPTION
4080
4081 Imager is a module for creating and altering images.  It can read and
4082 write various image formats, draw primitive shapes like lines,and
4083 polygons, blend multiple images together in various ways, scale, crop,
4084 render text and more.
4085
4086 =head2 Overview of documentation
4087
4088 =over
4089
4090 =item *
4091
4092 Imager - This document - Synopsis, Example, Table of Contents and
4093 Overview.
4094
4095 =item *
4096
4097 L<Imager::Tutorial> - a brief introduction to Imager.
4098
4099 =item *
4100
4101 L<Imager::Cookbook> - how to do various things with Imager.
4102
4103 =item *
4104
4105 L<Imager::ImageTypes> - Basics of constructing image objects with
4106 C<new()>: Direct type/virtual images, RGB(A)/paletted images,
4107 8/16/double bits/channel, color maps, channel masks, image tags, color
4108 quantization.  Also discusses basic image information methods.
4109
4110 =item *
4111
4112 L<Imager::Files> - IO interaction, reading/writing images, format
4113 specific tags.
4114
4115 =item *
4116
4117 L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4118 flood fill.
4119
4120 =item *
4121
4122 L<Imager::Color> - Color specification.
4123
4124 =item *
4125
4126 L<Imager::Fill> - Fill pattern specification.
4127
4128 =item *
4129
4130 L<Imager::Font> - General font rendering, bounding boxes and font
4131 metrics.
4132
4133 =item *
4134
4135 L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4136 blending, pasting, convert and map.
4137
4138 =item *
4139
4140 L<Imager::Engines> - Programmable transformations through
4141 C<transform()>, C<transform2()> and C<matrix_transform()>.
4142
4143 =item *
4144
4145 L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
4146 filter plug-ins.
4147
4148 =item *
4149
4150 L<Imager::Expr> - Expressions for evaluation engine used by
4151 transform2().
4152
4153 =item *
4154
4155 L<Imager::Matrix2d> - Helper class for affine transformations.
4156
4157 =item *
4158
4159 L<Imager::Fountain> - Helper for making gradient profiles.
4160
4161 =item *
4162
4163 L<Imager::API> - using Imager's C API
4164
4165 =item *
4166
4167 L<Imager::APIRef> - API function reference
4168
4169 =item *
4170
4171 L<Imager::Inline> - using Imager's C API from Inline::C
4172
4173 =item *
4174
4175 L<Imager::ExtUtils> - tools to get access to Imager's C API.
4176
4177 =back
4178
4179 =head2 Basic Overview
4180
4181 An Image object is created with C<$img = Imager-E<gt>new()>.
4182 Examples:
4183
4184   $img=Imager->new();                         # create empty image
4185   $img->read(file=>'lena.png',type=>'png') or # read image from file
4186      die $img->errstr();                      # give an explanation
4187                                               # if something failed
4188
4189 or if you want to create an empty image:
4190
4191   $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
4192
4193 This example creates a completely black image of width 400 and height
4194 300 and 4 channels.
4195
4196 =head1 ERROR HANDLING
4197
4198 In general a method will return false when it fails, if it does use
4199 the C<errstr()> method to find out why:
4200
4201 =over
4202
4203 =item C<errstr>
4204
4205 Returns the last error message in that context.
4206
4207 If the last error you received was from calling an object method, such
4208 as read, call errstr() as an object method to find out why:
4209
4210   my $image = Imager->new;
4211   $image->read(file => 'somefile.gif')
4212      or die $image->errstr;
4213
4214 If it was a class method then call errstr() as a class method:
4215
4216   my @imgs = Imager->read_multi(file => 'somefile.gif')
4217     or die Imager->errstr;
4218
4219 Note that in some cases object methods are implemented in terms of
4220 class methods so a failing object method may set both.
4221
4222 =back
4223
4224 The C<Imager-E<gt>new> method is described in detail in
4225 L<Imager::ImageTypes>.
4226
4227 =head1 METHOD INDEX
4228
4229 Where to find information on methods for Imager class objects.
4230
4231 addcolors() - L<Imager::ImageTypes/addcolors> - add colors to a
4232 paletted image
4233
4234 addtag() -  L<Imager::ImageTypes/addtag> - add image tags
4235
4236 align_string() - L<Imager::Draw/align_string> - draw text aligned on a
4237 point
4238
4239 arc() - L<Imager::Draw/arc> - draw a filled arc
4240
4241 bits() - L<Imager::ImageTypes/bits> - number of bits per sample for the
4242 image
4243
4244 box() - L<Imager::Draw/box> - draw a filled or outline box.
4245
4246 circle() - L<Imager::Draw/circle> - draw a filled circle
4247
4248 colorcount() - L<Imager::Draw/colorcount> - the number of colors in an
4249 image's palette (paletted images only)
4250
4251 combine() - L<Imager::Transformations/combine> - combine channels from one or
4252 more images.
4253
4254 combines() - L<Imager::Draw/combines> - return a list of the different
4255 combine type keywords
4256
4257 compose() - L<Imager::Transformations/compose> - compose one image
4258 over another.
4259
4260 convert() - L<Imager::Transformations/"Color transformations"> -
4261 transform the color space
4262
4263 copy() - L<Imager::Transformations/copy> - make a duplicate of an
4264 image
4265
4266 crop() - L<Imager::Transformations/crop> - extract part of an image
4267
4268 def_guess_type() - L<Imager::Files/def_guess_type> - default function
4269 used to guess the output file format based on the output file name
4270
4271 deltag() -  L<Imager::ImageTypes/deltag> - delete image tags
4272
4273 difference() - L<Imager::Filters/"Image Difference"> - produce a
4274 difference images from two input images.
4275
4276 errstr() - L<"Basic Overview"> - the error from the last failed
4277 operation.
4278
4279 filter() - L<Imager::Filters> - image filtering
4280
4281 findcolor() - L<Imager::ImageTypes/findcolor> - search the image
4282 palette, if it has one
4283
4284 flip() - L<Imager::Transformations/flip> - flip an image, vertically,
4285 horizontally
4286
4287 flood_fill() - L<Imager::Draw/flood_fill> - fill an enclosed or same
4288 color area
4289
4290 getchannels() - L<Imager::ImageTypes/getchannels> - the number of
4291 samples per pixel for an image
4292
4293 getcolorcount() - L<Imager::ImageTypes/getcolorcount> - the number of
4294 different colors used by an image (works for direct color images)
4295
4296 getcolors() - L<Imager::ImageTypes/getcolors> - get colors from the image
4297 palette, if it has one
4298
4299 getcolorusage() - L<Imager::ImageTypes/getcolorusage>
4300
4301 getcolorusagehash() - L<Imager::ImageTypes/getcolorusagehash>
4302
4303 get_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
4304
4305 getheight() - L<Imager::ImageTypes/getwidth> - height of the image in
4306 pixels
4307
4308 getmask() - L<Imager::ImageTypes/getmask> - write mask for the image
4309
4310 getpixel() - L<Imager::Draw/getpixel> - retrieve one or more pixel
4311 colors
4312
4313 getsamples() - L<Imager::Draw/getsamples> - retrieve samples from a
4314 row or partial row of pixels.
4315
4316 getscanline() - L<Imager::Draw/getscanline> - retrieve colors for a
4317 row or partial row of pixels.
4318
4319 getwidth() - L<Imager::ImageTypes/getwidth> - width of the image in
4320 pixels.
4321
4322 img_set() - L<Imager::ImageTypes/img_set> - re-use an Imager object
4323 for a new image.
4324
4325 init() - L<Imager::ImageTypes/init>
4326
4327 is_bilevel() - L<Imager::ImageTypes/is_bilevel> - returns whether
4328 image write functions should write the image in their bilevel (blank
4329 and white, no gray levels) format
4330
4331 line() - L<Imager::Draw/line> - draw an interval
4332
4333 load_plugin() - L<Imager::Filters/load_plugin>
4334
4335 map() - L<Imager::Transformations/"Color Mappings"> - remap color
4336 channel values
4337
4338 masked() -  L<Imager::ImageTypes/masked> - make a masked image
4339
4340 matrix_transform() - L<Imager::Engines/matrix_transform>
4341
4342 maxcolors() - L<Imager::ImageTypes/maxcolors>
4343
4344 NC() - L<Imager::Handy/NC>
4345
4346 NCF() - L<Imager::Handy/NCF>
4347
4348 new() - L<Imager::ImageTypes/new>
4349
4350 newcolor() - L<Imager::Handy/newcolor>
4351
4352 newcolour() - L<Imager::Handy/newcolour>
4353
4354 newfont() - L<Imager::Handy/newfont>
4355
4356 NF() - L<Imager::Handy/NF>
4357
4358 open() - L<Imager::Files> - an alias for read()
4359
4360 =for stopwords IPTC
4361
4362 parseiptc() - L<Imager::Files/parseiptc> - parse IPTC data from a JPEG
4363 image
4364
4365 paste() - L<Imager::Transformations/paste> - draw an image onto an image
4366
4367 polygon() - L<Imager::Draw/polygon>
4368
4369 polyline() - L<Imager::Draw/polyline>
4370
4371 preload() - L<Imager::Files/preload>
4372
4373 read() - L<Imager::Files> - read a single image from an image file
4374
4375 read_multi() - L<Imager::Files> - read multiple images from an image
4376 file
4377
4378 read_types() - L<Imager::Files/read_types> - list image types Imager
4379 can read.
4380
4381 register_filter() - L<Imager::Filters/register_filter>
4382
4383 register_reader() - L<Imager::Files/register_reader>
4384
4385 register_writer() - L<Imager::Files/register_writer>
4386
4387 rotate() - L<Imager::Transformations/rotate>
4388
4389 rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
4390 image and use the alpha channel
4391
4392 scale() - L<Imager::Transformations/scale>
4393
4394 scale_calculate() - L<Imager::Transformations/scale_calculate>
4395
4396 scaleX() - L<Imager::Transformations/scaleX>
4397
4398 scaleY() - L<Imager::Transformations/scaleY>
4399
4400 setcolors() - L<Imager::ImageTypes/setcolors> - set palette colors in
4401 a paletted image
4402
4403 set_file_limits() - L<Imager::Files/"Limiting the sizes of images you read">
4404
4405 setmask() - L<Imager::ImageTypes/setmask>
4406
4407 setpixel() - L<Imager::Draw/setpixel>
4408
4409 setsamples() - L<Imager::Draw/setsamples>
4410
4411 setscanline() - L<Imager::Draw/setscanline>
4412
4413 settag() - L<Imager::ImageTypes/settag>
4414
4415 string() - L<Imager::Draw/string> - draw text on an image
4416
4417 tags() -  L<Imager::ImageTypes/tags> - fetch image tags
4418
4419 to_paletted() -  L<Imager::ImageTypes/to_paletted>
4420
4421 to_rgb16() - L<Imager::ImageTypes/to_rgb16>
4422
4423 to_rgb8() - L<Imager::ImageTypes/to_rgb8>
4424
4425 transform() - L<Imager::Engines/"transform">
4426
4427 transform2() - L<Imager::Engines/"transform2">
4428
4429 type() -  L<Imager::ImageTypes/type> - type of image (direct vs paletted)
4430
4431 unload_plugin() - L<Imager::Filters/unload_plugin>
4432
4433 virtual() - L<Imager::ImageTypes/virtual> - whether the image has it's own
4434 data
4435
4436 write() - L<Imager::Files> - write an image to a file
4437
4438 write_multi() - L<Imager::Files> - write multiple image to an image
4439 file.
4440
4441 write_types() - L<Imager::Files/read_types> - list image types Imager
4442 can write.
4443
4444 =head1 CONCEPT INDEX
4445
4446 animated GIF - L<Imager::Files/"Writing an animated GIF">
4447
4448 aspect ratio - L<Imager::ImageTypes/i_xres>,
4449 L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
4450
4451 blend - alpha blending one image onto another
4452 L<Imager::Transformations/rubthrough>
4453
4454 blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
4455
4456 boxes, drawing - L<Imager::Draw/box>
4457
4458 changes between image - L<Imager::Filters/"Image Difference">
4459
4460 channels, combine into one image - L<Imager::Transformations/combine>
4461
4462 color - L<Imager::Color>
4463
4464 color names - L<Imager::Color>, L<Imager::Color::Table>
4465
4466 combine modes - L<Imager::Draw/"Combine Types">
4467
4468 compare images - L<Imager::Filters/"Image Difference">
4469
4470 contrast - L<Imager::Filters/contrast>, L<Imager::Filters/autolevels>
4471
4472 convolution - L<Imager::Filters/conv>
4473
4474 cropping - L<Imager::Transformations/crop>
4475
4476 CUR files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4477
4478 C<diff> images - L<Imager::Filters/"Image Difference">
4479
4480 dpi - L<Imager::ImageTypes/i_xres>,
4481 L<Imager::Cookbook/"Image spatial resolution">
4482
4483 drawing boxes - L<Imager::Draw/box>
4484
4485 drawing lines - L<Imager::Draw/line>
4486
4487 drawing text - L<Imager::Draw/string>, L<Imager::Draw/align_string>
4488
4489 error message - L<"ERROR HANDLING">
4490
4491 files, font - L<Imager::Font>
4492
4493 files, image - L<Imager::Files>
4494
4495 filling, types of fill - L<Imager::Fill>
4496
4497 filling, boxes - L<Imager::Draw/box>
4498
4499 filling, flood fill - L<Imager::Draw/flood_fill>
4500
4501 flood fill - L<Imager::Draw/flood_fill>
4502
4503 fonts - L<Imager::Font>
4504
4505 fonts, drawing with - L<Imager::Draw/string>,
4506 L<Imager::Draw/align_string>, L<Imager::Font::Wrap>
4507
4508 fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4509
4510 fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
4511
4512 fountain fill - L<Imager::Fill/"Fountain fills">,
4513 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4514 L<Imager::Filters/gradgen>
4515
4516 GIF files - L<Imager::Files/"GIF">
4517
4518 GIF files, animated - L<Imager::File/"Writing an animated GIF">
4519
4520 gradient fill - L<Imager::Fill/"Fountain fills">,
4521 L<Imager::Filters/fountain>, L<Imager::Fountain>,
4522 L<Imager::Filters/gradgen>
4523
4524 gray scale, convert image to - L<Imager::Transformations/convert>
4525
4526 guassian blur - L<Imager::Filters/guassian>
4527
4528 hatch fills - L<Imager::Fill/"Hatched fills">
4529
4530 ICO files - L<Imager::Files/"ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor)">
4531
4532 invert image - L<Imager::Filters/hardinvert>,
4533 L<Imager::Filters/hardinvertall>
4534
4535 JPEG - L<Imager::Files/"JPEG">
4536
4537 limiting image sizes - L<Imager::Files/"Limiting the sizes of images you read">
4538
4539 lines, drawing - L<Imager::Draw/line>
4540
4541 matrix - L<Imager::Matrix2d>,
4542 L<Imager::Transformations/"Matrix Transformations">,
4543 L<Imager::Font/transform>
4544
4545 metadata, image - L<Imager::ImageTypes/"Tags">
4546
4547 mosaic - L<Imager::Filters/mosaic>
4548
4549 noise, filter - L<Imager::Filters/noise>
4550
4551 noise, rendered - L<Imager::Filters/turbnoise>,
4552 L<Imager::Filters/radnoise>
4553
4554 paste - L<Imager::Transformations/paste>,
4555 L<Imager::Transformations/rubthrough>
4556
4557 pseudo-color image - L<Imager::ImageTypes/to_paletted>,
4558 L<Imager::ImageTypes/new>
4559
4560 =for stopwords posterize
4561
4562 posterize - L<Imager::Filters/postlevels>
4563
4564 PNG files - L<Imager::Files>, L<Imager::Files/"PNG">
4565
4566 PNM - L<Imager::Files/"PNM (Portable aNy Map)">
4567
4568 rectangles, drawing - L<Imager::Draw/box>
4569
4570 resizing an image - L<Imager::Transformations/scale>,
4571 L<Imager::Transformations/crop>
4572
4573 RGB (SGI) files - L<Imager::Files/"SGI (RGB, BW)">
4574
4575 saving an image - L<Imager::Files>
4576
4577 scaling - L<Imager::Transformations/scale>
4578
4579 SGI files - L<Imager::Files/"SGI (RGB, BW)">
4580
4581 sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
4582
4583 size, image - L<Imager::ImageTypes/getwidth>,
4584 L<Imager::ImageTypes/getheight>
4585
4586 size, text - L<Imager::Font/bounding_box>
4587
4588 tags, image metadata - L<Imager::ImageTypes/"Tags">
4589
4590 text, drawing - L<Imager::Draw/string>, L<Imager::Draw/align_string>,
4591 L<Imager::Font::Wrap>
4592
4593 text, wrapping text in an area - L<Imager::Font::Wrap>
4594
4595 text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
4596
4597 tiles, color - L<Imager::Filters/mosaic>
4598
4599 transparent images - L<Imager::ImageTypes>,
4600 L<Imager::Cookbook/"Transparent PNG">
4601
4602 =for stopwords unsharp
4603
4604 unsharp mask - L<Imager::Filters/unsharpmask>
4605
4606 watermark - L<Imager::Filters/watermark>
4607
4608 writing an image to a file - L<Imager::Files>
4609
4610 =head1 THREADS
4611
4612 Imager doesn't support perl threads.
4613
4614 Imager has limited code to prevent double frees if you create images,
4615 colors etc, and then create a thread, but has no code to prevent two
4616 threads entering Imager's error handling code, and none is likely to
4617 be added.
4618
4619 =head1 SUPPORT
4620
4621 The best place to get help with Imager is the mailing list.
4622
4623 To subscribe send a message with C<subscribe> in the body to:
4624
4625    imager-devel+request@molar.is
4626
4627 or use the form at:
4628
4629 =over
4630
4631 L<http://www.molar.is/en/lists/imager-devel/>
4632
4633 =back
4634
4635 where you can also find the mailing list archive.
4636
4637 You can report bugs by pointing your browser at:
4638
4639 =over
4640
4641 L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager>
4642
4643 =back
4644
4645 or by sending an email to:
4646
4647 =over
4648
4649 bug-Imager@rt.cpan.org
4650
4651 =back
4652
4653 Please remember to include the versions of Imager, perl, supporting
4654 libraries, and any relevant code.  If you have specific images that
4655 cause the problems, please include those too.
4656
4657 If you don't want to publish your email address on a mailing list you
4658 can use CPAN::Forum:
4659
4660   http://www.cpanforum.com/dist/Imager
4661
4662 You will need to register to post.
4663
4664 =head1 CONTRIBUTING TO IMAGER
4665
4666 =head2 Feedback
4667
4668 I like feedback.
4669
4670 If you like or dislike Imager, you can add a public review of Imager
4671 at CPAN Ratings:
4672
4673   http://cpanratings.perl.org/dist/Imager
4674
4675 =for stopwords Bitcard
4676
4677 This requires a Bitcard account (http://www.bitcard.org).
4678
4679 You can also send email to the maintainer below.
4680
4681 If you send me a bug report via email, it will be copied to Request
4682 Tracker.
4683
4684 =head2 Patches
4685
4686 I accept patches, preferably against the main branch in subversion.
4687 You should include an explanation of the reason for why the patch is
4688 needed or useful.
4689
4690 Your patch should include regression tests where possible, otherwise
4691 it will be delayed until I get a chance to write them.
4692
4693 =head1 AUTHOR
4694
4695 Tony Cook <tony@imager.perl.org> is the current maintainer for Imager.
4696
4697 Arnar M. Hrafnkelsson is the original author of Imager.
4698
4699 Many others have contributed to Imager, please see the C<README> for a
4700 complete list.
4701
4702 =head1 LICENSE
4703
4704 Imager is licensed under the same terms as perl itself.
4705
4706 =for stopwords
4707 makeblendedfont Fontforge
4708
4709 A test font, FT2/fontfiles/MMOne.pfb, contains a Postscript operator
4710 definition copyrighted by Adobe.  See F<adobe.txt> in the source for
4711 license information.
4712
4713 =head1 SEE ALSO
4714
4715 L<perl>(1), L<Imager::ImageTypes>(3), L<Imager::Files>(3),
4716 L<Imager::Draw>(3), L<Imager::Color>(3), L<Imager::Fill>(3),
4717 L<Imager::Font>(3), L<Imager::Transformations>(3),
4718 L<Imager::Engines>(3), L<Imager::Filters>(3), L<Imager::Expr>(3),
4719 L<Imager::Matrix2d>(3), L<Imager::Fountain>(3)
4720
4721 L<http://imager.perl.org/>
4722
4723 L<Affix::Infix2Postfix>(3), L<Parse::RecDescent>(3)
4724
4725 Other perl imaging modules include:
4726
4727 L<GD>(3), L<Image::Magick>(3), L<Graphics::Magick>(3).
4728
4729 =cut