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