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