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