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