Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

4958 lines (4029 sloc) 120.227 kb
package Imager;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR %OPCODES $I2P $FORMATGUESS $warn_obsolete);
use IO::File;
use Imager::Color;
use Imager::Font;
@EXPORT_OK = qw(
init
init_log
DSO_open
DSO_close
DSO_funclist
DSO_call
load_plugin
unload_plugin
i_list_formats
i_color_new
i_color_set
i_color_info
i_img_info
i_img_setmask
i_img_getmask
i_line
i_line_aa
i_box
i_box_filled
i_arc
i_circle_aa
i_bezier_multi
i_poly_aa
i_poly_aa_cfill
i_copyto
i_rubthru
i_scaleaxis
i_scale_nn
i_haar
i_count_colors
i_gaussian
i_conv
i_convert
i_map
i_img_diff
i_tt_set_aa
i_tt_cp
i_tt_text
i_tt_bbox
i_readpnm_wiol
i_writeppm_wiol
i_readraw_wiol
i_writeraw_wiol
i_contrast
i_hardinvert
i_noise
i_bumpmap
i_postlevels
i_mosaic
i_watermark
malloc_state
list_formats
i_gifquant
newfont
newcolor
newcolour
NC
NF
NCF
);
@EXPORT=qw(
);
%EXPORT_TAGS=
(handy => [qw(
newfont
newcolor
NF
NC
NCF
)],
all => [@EXPORT_OK],
default => [qw(
load_plugin
unload_plugin
)]);
# registered file readers
my %readers;
# registered file writers
my %writers;
# modules we attempted to autoload
my %attempted_to_load;
# errors from loading files
my %file_load_errors;
# what happened when we tried to load
my %reader_load_errors;
my %writer_load_errors;
# library keys that are image file formats
my %file_formats = map { $_ => 1 } qw/tiff pnm gif png jpeg raw bmp tga/;
# image pixel combine types
my @combine_types =
qw/none normal multiply dissolve add subtract diff lighten darken
hue saturation value color/;
my %combine_types;
@combine_types{@combine_types} = 0 .. $#combine_types;
$combine_types{mult} = $combine_types{multiply};
$combine_types{'sub'} = $combine_types{subtract};
$combine_types{sat} = $combine_types{saturation};
# this will be used to store global defaults at some point
my %defaults;
BEGIN {
require Exporter;
my $ex_version = eval $Exporter::VERSION;
if ($ex_version < 5.57) {
@ISA = qw(Exporter);
}
$VERSION = '0.92_01';
require XSLoader;
XSLoader::load(Imager => $VERSION);
}
my %formats_low;
my %format_classes =
(
png => "Imager::File::PNG",
gif => "Imager::File::GIF",
tiff => "Imager::File::TIFF",
jpeg => "Imager::File::JPEG",
w32 => "Imager::Font::W32",
ft2 => "Imager::Font::FT2",
t1 => "Imager::Font::T1",
);
tie %formats, "Imager::FORMATS", \%formats_low, \%format_classes;
BEGIN {
for(i_list_formats()) { $formats_low{$_}++; }
%OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
$DEBUG=0;
# the members of the subhashes under %filters are:
# callseq - a list of the parameters to the underlying filter in the
# order they are passed
# callsub - a code ref that takes a named parameter list and calls the
# underlying filter
# defaults - a hash of default values
# names - defines names for value of given parameters so if the names
# field is foo=> { bar=>1 }, and the user supplies "bar" as the
# foo parameter, the filter will receive 1 for the foo
# parameter
$filters{contrast}={
callseq => ['image','intensity'],
callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
};
$filters{noise} ={
callseq => ['image', 'amount', 'subtype'],
defaults => { amount=>3,subtype=>0 },
callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
};
$filters{hardinvert} ={
callseq => ['image'],
defaults => { },
callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
};
$filters{hardinvertall} =
{
callseq => ['image'],
defaults => { },
callsub => sub { my %hsh=@_; i_hardinvertall($hsh{image}); }
};
$filters{autolevels} ={
callseq => ['image','lsat','usat','skew'],
defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
};
$filters{turbnoise} ={
callseq => ['image'],
defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
};
$filters{radnoise} ={
callseq => ['image'],
defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
};
$filters{conv} =
{
callseq => ['image', 'coef'],
defaults => { },
callsub =>
sub {
my %hsh=@_;
i_conv($hsh{image},$hsh{coef})
or die Imager->_error_as_msg() . "\n";
}
};
$filters{gradgen} =
{
callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
defaults => { dist => 0 },
callsub =>
sub {
my %hsh=@_;
my @colors = @{$hsh{colors}};
$_ = _color($_)
for @colors;
i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
}
};
$filters{nearest_color} =
{
callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
defaults => { },
callsub =>
sub {
my %hsh=@_;
# make sure the segments are specified with colors
my @colors;
for my $color (@{$hsh{colors}}) {
my $new_color = _color($color)
or die $Imager::ERRSTR."\n";
push @colors, $new_color;
}
i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors,
$hsh{dist})
or die Imager->_error_as_msg() . "\n";
},
};
$filters{gaussian} = {
callseq => [ 'image', 'stddev' ],
defaults => { },
callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
};
$filters{mosaic} =
{
callseq => [ qw(image size) ],
defaults => { size => 20 },
callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
};
$filters{bumpmap} =
{
callseq => [ qw(image bump elevation lightx lighty st) ],
defaults => { elevation=>0, st=> 2 },
callsub => sub {
my %hsh = @_;
i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
$hsh{lightx}, $hsh{lighty}, $hsh{st});
},
};
$filters{bumpmap_complex} =
{
callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
defaults => {
channel => 0,
tx => 0,
ty => 0,
Lx => 0.2,
Ly => 0.4,
Lz => -1.0,
cd => 1.0,
cs => 40,
n => 1.3,
Ia => [0,0,0],
Il => [255,255,255],
Is => [255,255,255],
},
callsub => sub {
my %hsh = @_;
for my $cname (qw/Ia Il Is/) {
my $old = $hsh{$cname};
my $new_color = _color($old)
or die $Imager::ERRSTR, "\n";
$hsh{$cname} = $new_color;
}
i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
$hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
$hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
$hsh{Is});
},
};
$filters{postlevels} =
{
callseq => [ qw(image levels) ],
defaults => { levels => 10 },
callsub => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
};
$filters{watermark} =
{
callseq => [ qw(image wmark tx ty pixdiff) ],
defaults => { pixdiff=>10, tx=>0, ty=>0 },
callsub =>
sub {
my %hsh = @_;
i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
$hsh{pixdiff});
},
};
$filters{fountain} =
{
callseq => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
names => {
ftype => { linear => 0,
bilinear => 1,
radial => 2,
radial_square => 3,
revolution => 4,
conical => 5 },
repeat => { none => 0,
sawtooth => 1,
triangle => 2,
saw_both => 3,
tri_both => 4,
},
super_sample => {
none => 0,
grid => 1,
random => 2,
circle => 3,
},
combine => {
none => 0,
normal => 1,
multiply => 2, mult => 2,
dissolve => 3,
add => 4,
subtract => 5, 'sub' => 5,
diff => 6,
lighten => 7,
darken => 8,
hue => 9,
sat => 10,
value => 11,
color => 12,
},
},
defaults => { ftype => 0, repeat => 0, combine => 0,
super_sample => 0, ssample_param => 4,
segments=>[
[ 0, 0.5, 1,
[0,0,0],
[255, 255, 255],
0, 0,
],
],
},
callsub =>
sub {
my %hsh = @_;
# make sure the segments are specified with colors
my @segments;
for my $segment (@{$hsh{segments}}) {
my @new_segment = @$segment;
$_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
push @segments, \@new_segment;
}
i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
$hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
$hsh{ssample_param}, \@segments)
or die Imager->_error_as_msg() . "\n";
},
};
$filters{unsharpmask} =
{
callseq => [ qw(image stddev scale) ],
defaults => { stddev=>2.0, scale=>1.0 },
callsub =>
sub {
my %hsh = @_;
i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
},
};
$FORMATGUESS=\&def_guess_type;
$warn_obsolete = 1;
}
#
# Non methods
#
# initlize Imager
# NOTE: this might be moved to an import override later on
sub import {
my $i = 1;
while ($i < @_) {
if ($_[$i] eq '-log-stderr') {
init_log(undef, 4);
splice(@_, $i, 1);
}
else {
++$i;
}
}
goto &Exporter::import;
}
sub init_log {
Imager->open_log(log => $_[0], level => $_[1]);
}
sub init {
my %parms=(loglevel=>1,@_);
if (exists $parms{'warn_obsolete'}) {
$warn_obsolete = $parms{'warn_obsolete'};
}
if ($parms{'log'}) {
Imager->open_log(log => $parms{log}, level => $parms{loglevel})
or return;
}
if (exists $parms{'t1log'}) {
if ($formats{t1}) {
if (Imager::Font::T1::i_init_t1($parms{'t1log'})) {
Imager->_set_error(Imager->_error_as_msg);
return;
}
}
}
return 1;
}
{
my $is_logging = 0;
sub open_log {
my $class = shift;
my (%opts) = ( loglevel => 1, @_ );
$is_logging = i_init_log($opts{log}, $opts{loglevel});
unless ($is_logging) {
Imager->_set_error(Imager->_error_as_msg());
return;
}
Imager->log("Imager $VERSION starting\n", 1);
return $is_logging;
}
sub close_log {
i_init_log(undef, -1);
$is_logging = 0;
}
sub log {
my ($class, $message, $level) = @_;
defined $level or $level = 1;
i_log_entry($message, $level);
}
sub is_logging {
return $is_logging;
}
}
END {
if ($DEBUG) {
print "shutdown code\n";
# for(keys %instances) { $instances{$_}->DESTROY(); }
malloc_state(); # how do decide if this should be used? -- store something from the import
print "Imager exiting\n";
}
}
# Load a filter plugin
sub load_plugin {
my ($filename)=@_;
my $i;
my ($DSO_handle,$str)=DSO_open($filename);
if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
my %funcs=DSO_funclist($DSO_handle);
if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf(" %2d: %s\n",$i++,$_); } }
$i=0;
for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
$DSOs{$filename}=[$DSO_handle,\%funcs];
for(keys %funcs) {
my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
$DEBUG && print "eval string:\n",$evstr,"\n";
eval $evstr;
print $@ if $@;
}
return 1;
}
# Unload a plugin
sub unload_plugin {
my ($filename)=@_;
if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
for(keys %{$funcref}) {
delete $filters{$_};
$DEBUG && print "unloading: $_\n";
}
my $rc=DSO_close($DSO_handle);
if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
return 1;
}
# take the results of i_error() and make a message out of it
sub _error_as_msg {
return join(": ", map $_->[0], i_errors());
}
# this function tries to DWIM for color parameters
# color objects are used as is
# simple scalars are simply treated as single parameters to Imager::Color->new
# hashrefs are treated as named argument lists to Imager::Color->new
# arrayrefs are treated as list arguments to Imager::Color->new iff any
# parameter is > 1
# other arrayrefs are treated as list arguments to Imager::Color::Float
sub _color {
my $arg = shift;
# perl 5.6.0 seems to do weird things to $arg if we don't make an
# explicitly stringified copy
# I vaguely remember a bug on this on p5p, but couldn't find it
# through bugs.perl.org (I had trouble getting it to find any bugs)
my $copy = $arg . "";
my $result;
if (ref $arg) {
if (UNIVERSAL::isa($arg, "Imager::Color")
|| UNIVERSAL::isa($arg, "Imager::Color::Float")) {
$result = $arg;
}
else {
if ($copy =~ /^HASH\(/) {
$result = Imager::Color->new(%$arg);
}
elsif ($copy =~ /^ARRAY\(/) {
$result = Imager::Color->new(@$arg);
}
else {
$Imager::ERRSTR = "Not a color";
}
}
}
else {
# assume Imager::Color::new knows how to handle it
$result = Imager::Color->new($arg);
}
return $result;
}
sub _combine {
my ($self, $combine, $default) = @_;
if (!defined $combine && ref $self) {
$combine = $self->{combine};
}
defined $combine or $combine = $defaults{combine};
defined $combine or $combine = $default;
if (exists $combine_types{$combine}) {
$combine = $combine_types{$combine};
}
return $combine;
}
sub _valid_image {
my ($self, $method) = @_;
$self->{IMG} and return 1;
my $msg = 'empty input image';
$msg = "$method: $msg" if $method;
$self->_set_error($msg);
return;
}
# returns first defined parameter
sub _first {
for (@_) {
return $_ if defined $_;
}
return undef;
}
#
# Methods to be called on objects.
#
# Create a new Imager object takes very few parameters.
# usually you call this method and then call open from
# the resulting object
sub new {
my $class = shift;
my $self ={};
my %hsh=@_;
bless $self,$class;
$self->{IMG}=undef; # Just to indicate what exists
$self->{ERRSTR}=undef; #
$self->{DEBUG}=$DEBUG;
$self->{DEBUG} and print "Initialized Imager\n";
if (defined $hsh{xsize} || defined $hsh{ysize}) {
unless ($self->img_set(%hsh)) {
$Imager::ERRSTR = $self->{ERRSTR};
return;
}
}
elsif (defined $hsh{file} ||
defined $hsh{fh} ||
defined $hsh{fd} ||
defined $hsh{callback} ||
defined $hsh{readcb} ||
defined $hsh{data}) {
# allow $img = Imager->new(file => $filename)
my %extras;
# type is already used as a parameter to new(), rename it for the
# call to read()
if ($hsh{filetype}) {
$extras{type} = $hsh{filetype};
}
unless ($self->read(%hsh, %extras)) {
$Imager::ERRSTR = $self->{ERRSTR};
return;
}
}
return $self;
}
# Copy an entire image with no changes
# - if an image has magic the copy of it will not be magical
sub copy {
my $self = shift;
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
unless (defined wantarray) {
my @caller = caller;
warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
return;
}
my $newcopy=Imager->new();
$newcopy->{IMG} = i_copy($self->{IMG});
return $newcopy;
}
# Paste a region
sub paste {
my $self = shift;
unless ($self->{IMG}) {
$self->_set_error('empty input image');
return;
}
my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
my $src = $input{img} || $input{src};
unless($src) {
$self->_set_error("no source image");
return;
}
$input{left}=0 if $input{left} <= 0;
$input{top}=0 if $input{top} <= 0;
my($r,$b)=i_img_info($src->{IMG});
my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
my ($src_right, $src_bottom);
if ($input{src_coords}) {
($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
}
else {
if (defined $input{src_maxx}) {
$src_right = $input{src_maxx};
}
elsif (defined $input{width}) {
if ($input{width} <= 0) {
$self->_set_error("paste: width must me positive");
return;
}
$src_right = $src_left + $input{width};
}
else {
$src_right = $r;
}
if (defined $input{src_maxy}) {
$src_bottom = $input{src_maxy};
}
elsif (defined $input{height}) {
if ($input{height} < 0) {
$self->_set_error("paste: height must be positive");
return;
}
$src_bottom = $src_top + $input{height};
}
else {
$src_bottom = $b;
}
}
$src_right > $r and $src_right = $r;
$src_bottom > $b and $src_bottom = $b;
if ($src_right <= $src_left
|| $src_bottom < $src_top) {
$self->_set_error("nothing to paste");
return;
}
i_copyto($self->{IMG}, $src->{IMG},
$src_left, $src_top, $src_right, $src_bottom,
$input{left}, $input{top});
return $self; # What should go here??
}
# Crop an image - i.e. return a new image that is smaller
sub crop {
my $self=shift;
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
unless (defined wantarray) {
my @caller = caller;
warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
return;
}
my %hsh=@_;
my ($w, $h, $l, $r, $b, $t) =
@hsh{qw(width height left right bottom top)};
# work through the various possibilities
if (defined $l) {
if (defined $w) {
$r = $l + $w;
}
elsif (!defined $r) {
$r = $self->getwidth;
}
}
elsif (defined $r) {
if (defined $w) {
$l = $r - $w;
}
else {
$l = 0;
}
}
elsif (defined $w) {
$l = int(0.5+($self->getwidth()-$w)/2);
$r = $l + $w;
}
else {
$l = 0;
$r = $self->getwidth;
}
if (defined $t) {
if (defined $h) {
$b = $t + $h;
}
elsif (!defined $b) {
$b = $self->getheight;
}
}
elsif (defined $b) {
if (defined $h) {
$t = $b - $h;
}
else {
$t = 0;
}
}
elsif (defined $h) {
$t=int(0.5+($self->getheight()-$h)/2);
$b=$t+$h;
}
else {
$t = 0;
$b = $self->getheight;
}
($l,$r)=($r,$l) if $l>$r;
($t,$b)=($b,$t) if $t>$b;
$l < 0 and $l = 0;
$r > $self->getwidth and $r = $self->getwidth;
$t < 0 and $t = 0;
$b > $self->getheight and $b = $self->getheight;
if ($l == $r || $t == $b) {
$self->_set_error("resulting image would have no content");
return;
}
if( $r < $l or $b < $t ) {
$self->_set_error("attempting to crop outside of the image");
return;
}
my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
return $dst;
}
sub _sametype {
my ($self, %opts) = @_;
$self->{IMG} or return $self->_set_error("Not a valid image");
my $x = $opts{xsize} || $self->getwidth;
my $y = $opts{ysize} || $self->getheight;
my $channels = $opts{channels} || $self->getchannels;
my $out = Imager->new;
if ($channels == $self->getchannels) {
$out->{IMG} = i_sametype($self->{IMG}, $x, $y);
}
else {
$out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
}
unless ($out->{IMG}) {
$self->{ERRSTR} = $self->_error_as_msg;
return;
}
return $out;
}
# Sets an image to a certain size and channel number
# if there was previously data in the image it is discarded
sub img_set {
my $self=shift;
my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
if (defined($self->{IMG})) {
# let IIM_DESTROY destroy it, it's possible this image is
# referenced from a virtual image (like masked)
#i_img_destroy($self->{IMG});
undef($self->{IMG});
}
if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
$self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
$hsh{maxcolors} || 256);
}
elsif ($hsh{bits} eq 'double') {
$self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
}
elsif ($hsh{bits} == 16) {
$self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
}
else {
$self->{IMG}= i_img_8_new($hsh{'xsize'}, $hsh{'ysize'},
$hsh{'channels'});
}
unless ($self->{IMG}) {
$self->{ERRSTR} = Imager->_error_as_msg();
return;
}
$self;
}
# created a masked version of the current image
sub masked {
my $self = shift;
$self or return undef;
my %opts = (left => 0,
top => 0,
right => $self->getwidth,
bottom => $self->getheight,
@_);
my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
my $result = Imager->new;
$result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
$opts{top}, $opts{right} - $opts{left},
$opts{bottom} - $opts{top});
unless ($result->{IMG}) {
$self->_set_error(Imager->_error_as_msg);
return;
}
# keep references to the mask and base images so they don't
# disappear on us
$result->{DEPENDS} = [ $self->{IMG}, $mask ];
return $result;
}
# convert an RGB image into a paletted image
sub to_paletted {
my $self = shift;
my $opts;
if (@_ != 1 && !ref $_[0]) {
$opts = { @_ };
}
else {
$opts = shift;
}
unless (defined wantarray) {
my @caller = caller;
warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
return;
}
$self->_valid_image
or return;
my $result = Imager->new;
unless ($result->{IMG} = i_img_to_pal($self->{IMG}, $opts)) {
$self->_set_error(Imager->_error_as_msg);
return;
}
return $result;
}
sub make_palette {
my ($class, $quant, @images) = @_;
unless (@images) {
Imager->_set_error("make_palette: supply at least one image");
return;
}
my $index = 1;
for my $img (@images) {
unless ($img->{IMG}) {
Imager->_set_error("make_palette: image $index is empty");
return;
}
++$index;
}
return i_img_make_palette($quant, map $_->{IMG}, @images);
}
# convert a paletted (or any image) to an 8-bit/channel RGB image
sub to_rgb8 {
my $self = shift;
unless (defined wantarray) {
my @caller = caller;
warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
return;
}
$self->_valid_image
or return;
my $result = Imager->new;
unless ($result->{IMG} = i_img_to_rgb($self->{IMG})) {
$self->_set_error(Imager->_error_as_msg());
return;
}
return $result;
}
# convert a paletted (or any image) to a 16-bit/channel RGB image
sub to_rgb16 {
my $self = shift;
unless (defined wantarray) {
my @caller = caller;
warn "to_rgb16() called in void context - to_rgb16() returns the converted image at $caller[1] line $caller[2]\n";
return;
}
$self->_valid_image
or return;
my $result = Imager->new;
unless ($result->{IMG} = i_img_to_rgb16($self->{IMG})) {
$self->_set_error(Imager->_error_as_msg());
return;
}
return $result;
}
# convert a paletted (or any image) to an double/channel RGB image
sub to_rgb_double {
my $self = shift;
unless (defined wantarray) {
my @caller = caller;
warn "to_rgb16() called in void context - to_rgb_double() returns the converted image at $caller[1] line $caller[2]\n";
return;
}
$self->_valid_image
or return;
my $result = Imager->new;
unless ($result->{IMG} = i_img_to_drgb($self->{IMG})) {
$self->_set_error(Imager->_error_as_msg());
return;
}
return $result;
}
sub addcolors {
my $self = shift;
my %opts = (colors=>[], @_);
unless ($self->{IMG}) {
$self->_set_error("empty input image");
return;
}
my @colors = @{$opts{colors}}
or return undef;
for my $color (@colors) {
$color = _color($color);
unless ($color) {
$self->_set_error($Imager::ERRSTR);
return;
}
}
return i_addcolors($self->{IMG}, @colors);
}
sub setcolors {
my $self = shift;
my %opts = (start=>0, colors=>[], @_);
unless ($self->{IMG}) {
$self->_set_error("empty input image");
return;
}
my @colors = @{$opts{colors}}
or return undef;
for my $color (@colors) {
$color = _color($color);
unless ($color) {
$self->_set_error($Imager::ERRSTR);
return;
}
}
return i_setcolors($self->{IMG}, $opts{start}, @colors);
}
sub getcolors {
my $self = shift;
my %opts = @_;
if (!exists $opts{start} && !exists $opts{count}) {
# get them all
$opts{start} = 0;
$opts{count} = $self->colorcount;
}
elsif (!exists $opts{count}) {
$opts{count} = 1;
}
elsif (!exists $opts{start}) {
$opts{start} = 0;
}
$self->{IMG} and
return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
}
sub colorcount {
i_colorcount($_[0]{IMG});
}
sub maxcolors {
i_maxcolors($_[0]{IMG});
}
sub findcolor {
my $self = shift;
my %opts = @_;
$opts{color} or return undef;
$self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
}
sub bits {
my $self = shift;
my $bits = $self->{IMG} && i_img_bits($self->{IMG});
if ($bits && $bits == length(pack("d", 1)) * 8) {
$bits = 'double';
}
$bits;
}
sub type {
my $self = shift;
if ($self->{IMG}) {
return i_img_type($self->{IMG}) ? "paletted" : "direct";
}
}
sub virtual {
my $self = shift;
$self->{IMG} and i_img_virtual($self->{IMG});
}
sub is_bilevel {
my ($self) = @_;
$self->{IMG} or return;
return i_img_is_monochrome($self->{IMG});
}
sub tags {
my ($self, %opts) = @_;
$self->{IMG} or return;
if (defined $opts{name}) {
my @result;
my $start = 0;
my $found;
while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
push @result, (i_tags_get($self->{IMG}, $found))[1];
$start = $found+1;
}
return wantarray ? @result : $result[0];
}
elsif (defined $opts{code}) {
my @result;
my $start = 0;
my $found;
while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
push @result, (i_tags_get($self->{IMG}, $found))[1];
$start = $found+1;
}
return @result;
}
else {
if (wantarray) {
return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
}
else {
return i_tags_count($self->{IMG});
}
}
}
sub addtag {
my $self = shift;
my %opts = @_;
return -1 unless $self->{IMG};
if ($opts{name}) {
if (defined $opts{value}) {
if ($opts{value} =~ /^\d+$/) {
# add as a number
return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
}
else {
return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
}
}
elsif (defined $opts{data}) {
# force addition as a string
return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
}
else {
$self->{ERRSTR} = "No value supplied";
return undef;
}
}
elsif ($opts{code}) {
if (defined $opts{value}) {
if ($opts{value} =~ /^\d+$/) {
# add as a number
return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
}
else {
return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
}
}
elsif (defined $opts{data}) {
# force addition as a string
return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
}
else {
$self->{ERRSTR} = "No value supplied";
return undef;
}
}
else {
return undef;
}
}
sub deltag {
my $self = shift;
my %opts = @_;
return 0 unless $self->{IMG};
if (defined $opts{'index'}) {
return i_tags_delete($self->{IMG}, $opts{'index'});
}
elsif (defined $opts{name}) {
return i_tags_delbyname($self->{IMG}, $opts{name});
}
elsif (defined $opts{code}) {
return i_tags_delbycode($self->{IMG}, $opts{code});
}
else {
$self->{ERRSTR} = "Need to supply index, name, or code parameter";
return 0;
}
}
sub settag {
my ($self, %opts) = @_;
if ($opts{name}) {
$self->deltag(name=>$opts{name});
return $self->addtag(name=>$opts{name}, value=>$opts{value});
}
elsif (defined $opts{code}) {
$self->deltag(code=>$opts{code});
return $self->addtag(code=>$opts{code}, value=>$opts{value});
}
else {
return undef;
}
}
sub _get_reader_io {
my ($self, $input) = @_;
if ($input->{io}) {
return $input->{io}, undef;
}
elsif ($input->{fd}) {
return io_new_fd($input->{fd});
}
elsif ($input->{fh}) {
my $fd = fileno($input->{fh});
unless (defined $fd) {
$self->_set_error("Handle in fh option not opened");
return;
}
return io_new_fd($fd);
}
elsif ($input->{file}) {
my $file = IO::File->new($input->{file}, "r");
unless ($file) {
$self->_set_error("Could not open $input->{file}: $!");
return;
}
binmode $file;
return (io_new_fd(fileno($file)), $file);
}
elsif ($input->{data}) {
return io_new_buffer($input->{data});
}
elsif ($input->{callback} || $input->{readcb}) {
if (!$input->{seekcb}) {
$self->_set_error("Need a seekcb parameter");
}
if ($input->{maxbuffer}) {
return io_new_cb($input->{writecb},
$input->{callback} || $input->{readcb},
$input->{seekcb}, $input->{closecb},
$input->{maxbuffer});
}
else {
return io_new_cb($input->{writecb},
$input->{callback} || $input->{readcb},
$input->{seekcb}, $input->{closecb});
}
}
else {
$self->_set_error("file/fd/fh/data/callback parameter missing");
return;
}
}
sub _get_writer_io {
my ($self, $input) = @_;
my $buffered = exists $input->{buffered} ? $input->{buffered} : 1;
my $io;
my @extras;
if ($input->{io}) {
$io = $input->{io};
}
elsif ($input->{fd}) {
$io = io_new_fd($input->{fd});
}
elsif ($input->{fh}) {
my $fd = fileno($input->{fh});
unless (defined $fd) {
$self->_set_error("Handle in fh option not opened");
return;
}
# flush it
my $oldfh = select($input->{fh});
# flush anything that's buffered, and make sure anything else is flushed
$| = 1;
select($oldfh);
$io = io_new_fd($fd);
}
elsif ($input->{file}) {
my $fh = new IO::File($input->{file},"w+");
unless ($fh) {
$self->_set_error("Could not open file $input->{file}: $!");
return;
}
binmode($fh) or die;
$io = io_new_fd(fileno($fh));
push @extras, $fh;
}
elsif ($input->{data}) {
$io = io_new_bufchain();
}
elsif ($input->{callback} || $input->{writecb}) {
if ($input->{maxbuffer} && $input->{maxbuffer} == 1) {
$buffered = 0;
}
$io = io_new_cb($input->{callback} || $input->{writecb},
$input->{readcb},
$input->{seekcb}, $input->{closecb});
}
else {
$self->_set_error("file/fd/fh/data/callback parameter missing");
return;
}
unless ($buffered) {
$io->set_buffered(0);
}
return ($io, @extras);
}
# Read an image from file
sub read {
my $self = shift;
my %input=@_;
if (defined($self->{IMG})) {
# let IIM_DESTROY do the destruction, since the image may be
# referenced from elsewhere
#i_img_destroy($self->{IMG});
undef($self->{IMG});
}
my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
my $type = $input{'type'};
unless ($type) {
$type = i_test_format_probe($IO, -1);
}
if ($input{file} && !$type) {
# guess the type
$type = $FORMATGUESS->($input{file});
}
unless ($type) {
my $msg = "type parameter missing and it couldn't be determined from the file contents";
$input{file} and $msg .= " or file name";
$self->_set_error($msg);
return undef;
}
_reader_autoload($type);
if ($readers{$type} && $readers{$type}{single}) {
return $readers{$type}{single}->($self, $IO, %input);
}
unless ($formats_low{$type}) {
my $read_types = join ', ', sort Imager->read_types();
$self->_set_error("format '$type' not supported - formats $read_types available for reading - $reader_load_errors{$type}");
return;
}
my $allow_incomplete = $input{allow_incomplete};
defined $allow_incomplete or $allow_incomplete = 0;
if ( $type eq 'pnm' ) {
$self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
if ( !defined($self->{IMG}) ) {
$self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
return undef;
}
$self->{DEBUG} && print "loading a pnm file\n";
return $self;
}
if ( $type eq 'bmp' ) {
$self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
if ( !defined($self->{IMG}) ) {
$self->{ERRSTR}=$self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "loading a bmp file\n";
}
if ( $type eq 'tga' ) {
$self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
if ( !defined($self->{IMG}) ) {
$self->{ERRSTR}=$self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "loading a tga file\n";
}
if ( $type eq 'raw' ) {
unless ( $input{xsize} && $input{ysize} ) {
$self->_set_error('missing xsize or ysize parameter for raw');
return undef;
}
my $interleave = _first($input{raw_interleave}, $input{interleave});
unless (defined $interleave) {
my @caller = caller;
warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
$interleave = 1;
}
my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
$self->{IMG} = i_readraw_wiol( $IO,
$input{xsize},
$input{ysize},
$data_ch,
$store_ch,
$interleave);
if ( !defined($self->{IMG}) ) {
$self->{ERRSTR}=$self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "loading a raw file\n";
}
return $self;
}
sub register_reader {
my ($class, %opts) = @_;
defined $opts{type}
or die "register_reader called with no type parameter\n";
my $type = $opts{type};
defined $opts{single} || defined $opts{multiple}
or die "register_reader called with no single or multiple parameter\n";
$readers{$type} = { };
if ($opts{single}) {
$readers{$type}{single} = $opts{single};
}
if ($opts{multiple}) {
$readers{$type}{multiple} = $opts{multiple};
}
return 1;
}
sub register_writer {
my ($class, %opts) = @_;
defined $opts{type}
or die "register_writer called with no type parameter\n";
my $type = $opts{type};
defined $opts{single} || defined $opts{multiple}
or die "register_writer called with no single or multiple parameter\n";
$writers{$type} = { };
if ($opts{single}) {
$writers{$type}{single} = $opts{single};
}
if ($opts{multiple}) {
$writers{$type}{multiple} = $opts{multiple};
}
return 1;
}
sub read_types {
my %types =
(
map { $_ => 1 }
keys %readers,
grep($file_formats{$_}, keys %formats),
qw(ico sgi), # formats not handled directly, but supplied with Imager
);
return keys %types;
}
sub write_types {
my %types =
(
map { $_ => 1 }
keys %writers,
grep($file_formats{$_}, keys %formats),
qw(ico sgi), # formats not handled directly, but supplied with Imager
);
return keys %types;
}
sub _load_file {
my ($file, $error) = @_;
if ($attempted_to_load{$file}) {
if ($file_load_errors{$file}) {
$$error = $file_load_errors{$file};
return 0;
}
else {
return 1;
}
}
else {
local $SIG{__DIE__};
my $loaded = eval {
++$attempted_to_load{$file};
require $file;
return 1;
};
if ($loaded) {
return 1;
}
else {
my $work = $@ || "Unknown error";
chomp $work;
$work =~ s/\n?Compilation failed in require at .*Imager\.pm line .*\z//m;
$work =~ s/\n/\\n/g;
$work =~ s/\s*\.?\z/ loading $file/;
$file_load_errors{$file} = $work;
$$error = $work;
return 0;
}
}
}
# probes for an Imager::File::whatever module
sub _reader_autoload {
my $type = shift;
return if $formats_low{$type} || $readers{$type};
return unless $type =~ /^\w+$/;
my $file = "Imager/File/\U$type\E.pm";
my $error;
my $loaded = _load_file($file, \$error);
if (!$loaded && $error =~ /^Can't locate /) {
my $filer = "Imager/File/\U$type\EReader.pm";
$loaded = _load_file($filer, \$error);
if ($error =~ /^Can't locate /) {
$error = "Can't locate $file or $filer";
}
}
unless ($loaded) {
$reader_load_errors{$type} = $error;
}
}
# probes for an Imager::File::whatever module
sub _writer_autoload {
my $type = shift;
return if $formats_low{$type} || $writers{$type};
return unless $type =~ /^\w+$/;
my $file = "Imager/File/\U$type\E.pm";
my $error;
my $loaded = _load_file($file, \$error);
if (!$loaded && $error =~ /^Can't locate /) {
my $filew = "Imager/File/\U$type\EWriter.pm";
$loaded = _load_file($filew, \$error);
if ($error =~ /^Can't locate /) {
$error = "Can't locate $file or $filew";
}
}
unless ($loaded) {
$writer_load_errors{$type} = $error;
}
}
sub _fix_gif_positions {
my ($opts, $opt, $msg, @imgs) = @_;
my $positions = $opts->{'gif_positions'};
my $index = 0;
for my $pos (@$positions) {
my ($x, $y) = @$pos;
my $img = $imgs[$index++];
$img->settag(name=>'gif_left', value=>$x);
$img->settag(name=>'gif_top', value=>$y) if defined $y;
}
$$msg .= "replaced with the gif_left and gif_top tags";
}
my %obsolete_opts =
(
gif_each_palette=>'gif_local_map',
interlace => 'gif_interlace',
gif_delays => 'gif_delay',
gif_positions => \&_fix_gif_positions,
gif_loop_count => 'gif_loop',
);
# options that should be converted to colors
my %color_opts = map { $_ => 1 } qw/i_background/;
sub _set_opts {
my ($self, $opts, $prefix, @imgs) = @_;
for my $opt (keys %$opts) {
my $tagname = $opt;
if ($obsolete_opts{$opt}) {
my $new = $obsolete_opts{$opt};
my $msg = "Obsolete option $opt ";
if (ref $new) {
$new->($opts, $opt, \$msg, @imgs);
}
else {
$msg .= "replaced with the $new tag ";
$tagname = $new;
}
$msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
warn $msg if $warn_obsolete && $^W;
}
next unless $tagname =~ /^\Q$prefix/;
my $value = $opts->{$opt};
if ($color_opts{$opt}) {
$value = _color($value);
unless ($value) {
$self->_set_error($Imager::ERRSTR);
return;
}
}
if (ref $value) {
if (UNIVERSAL::isa($value, "Imager::Color")) {
my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
for my $img (@imgs) {
$img->settag(name=>$tagname, value=>$tag);
}
}
elsif (ref($value) eq 'ARRAY') {
for my $i (0..$#$value) {
my $val = $value->[$i];
if (ref $val) {
if (UNIVERSAL::isa($val, "Imager::Color")) {
my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
$i < @imgs and
$imgs[$i]->settag(name=>$tagname, value=>$tag);
}
else {
$self->_set_error("Unknown reference type " . ref($value) .
" supplied in array for $opt");
return;
}
}
else {
$i < @imgs
and $imgs[$i]->settag(name=>$tagname, value=>$val);
}
}
}
else {
$self->_set_error("Unknown reference type " . ref($value) .
" supplied for $opt");
return;
}
}
else {
# set it as a tag for every image
for my $img (@imgs) {
$img->settag(name=>$tagname, value=>$value);
}
}
}
return 1;
}
# Write an image to file
sub write {
my $self = shift;
my %input=(jpegquality=>75,
gifquant=>'mc',
lmdither=>6.0,
lmfixed=>[],
idstring=>"",
compress=>1,
wierdpack=>0,
fax_fine=>1, @_);
my $rc;
$self->_set_opts(\%input, "i_", $self)
or return undef;
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
my $type = $input{'type'};
if (!$type and $input{file}) {
$type = $FORMATGUESS->($input{file});
}
unless ($type) {
$self->{ERRSTR}='type parameter missing and not possible to guess from extension';
return undef;
}
_writer_autoload($type);
my ($IO, $fh);
if ($writers{$type} && $writers{$type}{single}) {
($IO, $fh) = $self->_get_writer_io(\%input)
or return undef;
$writers{$type}{single}->($self, $IO, %input, type => $type)
or return undef;
}
else {
if (!$formats_low{$type}) {
my $write_types = join ', ', sort Imager->write_types();
$self->_set_error("format '$type' not supported - formats $write_types available for writing - $writer_load_errors{$type}");
return undef;
}
($IO, $fh) = $self->_get_writer_io(\%input, $type)
or return undef;
if ( $type eq 'pnm' ) {
$self->_set_opts(\%input, "pnm_", $self)
or return undef;
if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
$self->{ERRSTR} = $self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "writing a pnm file\n";
}
elsif ( $type eq 'raw' ) {
$self->_set_opts(\%input, "raw_", $self)
or return undef;
if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
$self->{ERRSTR} = $self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "writing a raw file\n";
}
elsif ( $type eq 'bmp' ) {
$self->_set_opts(\%input, "bmp_", $self)
or return undef;
if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
$self->{ERRSTR} = $self->_error_as_msg;
return undef;
}
$self->{DEBUG} && print "writing a bmp file\n";
}
elsif ( $type eq 'tga' ) {
$self->_set_opts(\%input, "tga_", $self)
or return undef;
if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
$self->{ERRSTR}=$self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "writing a tga file\n";
}
}
if (exists $input{'data'}) {
my $data = io_slurp($IO);
if (!$data) {
$self->{ERRSTR}='Could not slurp from buffer';
return undef;
}
${$input{data}} = $data;
}
return $self;
}
sub write_multi {
my ($class, $opts, @images) = @_;
my $type = $opts->{type};
if (!$type && $opts->{'file'}) {
$type = $FORMATGUESS->($opts->{'file'});
}
unless ($type) {
$class->_set_error('type parameter missing and not possible to guess from extension');
return;
}
# translate to ImgRaw
if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
$class->_set_error('Usage: Imager->write_multi({ options }, @images)');
return 0;
}
$class->_set_opts($opts, "i_", @images)
or return;
my @work = map $_->{IMG}, @images;
_writer_autoload($type);
my ($IO, $file);
if ($writers{$type} && $writers{$type}{multiple}) {
($IO, $file) = $class->_get_writer_io($opts, $type)
or return undef;
$writers{$type}{multiple}->($class, $IO, $opts, @images)
or return undef;
}
else {
if (!$formats{$type}) {
my $write_types = join ', ', sort Imager->write_types();
$class->_set_error("format '$type' not supported - formats $write_types available for writing");
return undef;
}
($IO, $file) = $class->_get_writer_io($opts, $type)
or return undef;
if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
}
else {
if (@images == 1) {
unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
return 1;
}
}
else {
$ERRSTR = "Sorry, write_multi doesn't support $type yet";
return 0;
}
}
}
if (exists $opts->{'data'}) {
my $data = io_slurp($IO);
if (!$data) {
Imager->_set_error('Could not slurp from buffer');
return undef;
}
${$opts->{data}} = $data;
}
return 1;
}
# read multiple images from a file
sub read_multi {
my ($class, %opts) = @_;
my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
or return;
my $type = $opts{'type'};
unless ($type) {
$type = i_test_format_probe($IO, -1);
}
if ($opts{file} && !$type) {
# guess the type
$type = $FORMATGUESS->($opts{file});
}
unless ($type) {
my $msg = "type parameter missing and it couldn't be determined from the file contents";
$opts{file} and $msg .= " or file name";
Imager->_set_error($msg);
return;
}
_reader_autoload($type);
if ($readers{$type} && $readers{$type}{multiple}) {
return $readers{$type}{multiple}->($IO, %opts);
}
unless ($formats{$type}) {
my $read_types = join ', ', sort Imager->read_types();
Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
return;
}
my @imgs;
if ($type eq 'pnm') {
@imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
}
else {
my $img = Imager->new;
if ($img->read(%opts, io => $IO, type => $type)) {
return ( $img );
}
Imager->_set_error($img->errstr);
return;
}
if (!@imgs) {
$ERRSTR = _error_as_msg();
return;
}
return map {
bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
} @imgs;
}
# Destroy an Imager object
sub DESTROY {
my $self=shift;
# delete $instances{$self};
if (defined($self->{IMG})) {
# the following is now handled by the XS DESTROY method for
# Imager::ImgRaw object
# Re-enabling this will break virtual images
# tested for in t/t020masked.t
# i_img_destroy($self->{IMG});
undef($self->{IMG});
} else {
# print "Destroy Called on an empty image!\n"; # why did I put this here??
}
}
# Perform an inplace filter of an image
# that is the image will be overwritten with the data
sub filter {
my $self=shift;
my %input=@_;
my %hsh;
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
$self->{ERRSTR}='type parameter not matching any filter'; return undef;
}
if ($filters{$input{'type'}}{names}) {
my $names = $filters{$input{'type'}}{names};
for my $name (keys %$names) {
if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
$input{$name} = $names->{$name}{$input{$name}};
}
}
}
if (defined($filters{$input{'type'}}{defaults})) {
%hsh=( image => $self->{IMG},
imager => $self,
%{$filters{$input{'type'}}{defaults}},
%input );
} else {
%hsh=( image => $self->{IMG},
imager => $self,
%input );
}
my @cs=@{$filters{$input{'type'}}{callseq}};
for(@cs) {
if (!defined($hsh{$_})) {
$self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
}
}
eval {
local $SIG{__DIE__}; # we don't want this processed by confess, etc
&{$filters{$input{'type'}}{callsub}}(%hsh);
};
if ($@) {
chomp($self->{ERRSTR} = $@);
return;
}
my @b=keys %hsh;
$self->{DEBUG} && print "callseq is: @cs\n";
$self->{DEBUG} && print "matching callseq is: @b\n";
return $self;
}
sub register_filter {
my $class = shift;
my %hsh = ( defaults => {}, @_ );
defined $hsh{type}
or die "register_filter() with no type\n";
defined $hsh{callsub}
or die "register_filter() with no callsub\n";
defined $hsh{callseq}
or die "register_filter() with no callseq\n";
exists $filters{$hsh{type}}
and return;
$filters{$hsh{type}} = \%hsh;
return 1;
}
sub scale_calculate {
my $self = shift;
my %opts = ('type'=>'max', @_);
# none of these should be references
for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
if (defined $opts{$name} && ref $opts{$name}) {
$self->_set_error("scale_calculate: $name parameter cannot be a reference");
return;
}
}
my ($x_scale, $y_scale);
my $width = $opts{width};
my $height = $opts{height};
if (ref $self) {
defined $width or $width = $self->getwidth;
defined $height or $height = $self->getheight;
}
else {
unless (defined $width && defined $height) {
$self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
return;
}
}
if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
$x_scale = $opts{'xscalefactor'};
$y_scale = $opts{'yscalefactor'};
}
elsif ($opts{'xscalefactor'}) {
$x_scale = $opts{'xscalefactor'};
$y_scale = $opts{'scalefactor'} || $x_scale;
}
elsif ($opts{'yscalefactor'}) {
$y_scale = $opts{'yscalefactor'};
$x_scale = $opts{'scalefactor'} || $y_scale;
}
else {
$x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
}
# work out the scaling
if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
my ($xpix, $ypix)=( $opts{xpixels} / $width ,
$opts{ypixels} / $height );
if ($opts{'type'} eq 'min') {
$x_scale = $y_scale = _min($xpix,$ypix);
}
elsif ($opts{'type'} eq 'max') {
$x_scale = $y_scale = _max($xpix,$ypix);
}
elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
$x_scale = $xpix;
$y_scale = $ypix;
}
else {
$self->_set_error('invalid value for type parameter');
return;
}
} elsif ($opts{xpixels}) {
$x_scale = $y_scale = $opts{xpixels} / $width;
}
elsif ($opts{ypixels}) {
$x_scale = $y_scale = $opts{ypixels}/$height;
}
elsif ($opts{constrain} && ref $opts{constrain}
&& $opts{constrain}->can('constrain')) {
# we've been passed an Image::Math::Constrain object or something
# that looks like one
my $scalefactor;
(undef, undef, $scalefactor)
= $opts{constrain}->constrain($self->getwidth, $self->getheight);
unless ($scalefactor) {
$self->_set_error('constrain method failed on constrain parameter');
return;
}
$x_scale = $y_scale = $scalefactor;
}
my $new_width = int($x_scale * $width + 0.5);
$new_width > 0 or $new_width = 1;
my $new_height = int($y_scale * $height + 0.5);
$new_height > 0 or $new_height = 1;
return ($x_scale, $y_scale, $new_width, $new_height);
}
# Scale an image to requested size and return the scaled version
sub scale {
my $self=shift;
my %opts = (qtype=>'normal' ,@_);
my $img = Imager->new();
my $tmp = Imager->new();
unless (defined wantarray) {
my @caller = caller;
warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
return;
}
unless ($self->{IMG}) {
$self->_set_error('empty input image');
return undef;
}
my ($x_scale, $y_scale, $new_width, $new_height) =
$self->scale_calculate(%opts)
or return;
if ($opts{qtype} eq 'normal') {
$tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
if ( !defined($tmp->{IMG}) ) {
$self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
return undef;
}
$img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
if ( !defined($img->{IMG}) ) {
$self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
return undef;
}
return $img;
}
elsif ($opts{'qtype'} eq 'preview') {
$img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
if ( !defined($img->{IMG}) ) {
$self->{ERRSTR}='unable to scale image';
return undef;
}
return $img;
}
elsif ($opts{'qtype'} eq 'mixing') {
$img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
unless ($img->{IMG}) {
$self->_set_error(Imager->_error_as_msg);
return;
}
return $img;
}
else {
$self->_set_error('invalid value for qtype parameter');
return undef;
}
}
# Scales only along the X axis
sub scaleX {
my $self = shift;
my %opts = ( scalefactor=>0.5, @_ );
unless (defined wantarray) {
my @caller = caller;
warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
return;
}
unless ($self->{IMG}) {
$self->{ERRSTR} = 'empty input image';
return undef;
}
my $img = Imager->new();
my $scalefactor = $opts{scalefactor};
if ($opts{pixels}) {
$scalefactor = $opts{pixels} / $self->getwidth();
}
unless ($self->{IMG}) {
$self->{ERRSTR}='empty input image';
return undef;
}
$img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
if ( !defined($img->{IMG}) ) {
$self->{ERRSTR} = 'unable to scale image';
return undef;
}
return $img;
}
# Scales only along the Y axis
sub scaleY {
my $self = shift;
my %opts = ( scalefactor => 0.5, @_ );
unless (defined wantarray) {
my @caller = caller;
warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
return;
}
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
my $img = Imager->new();
my $scalefactor = $opts{scalefactor};
if ($opts{pixels}) {
$scalefactor = $opts{pixels} / $self->getheight();
}
unless ($self->{IMG}) {
$self->{ERRSTR} = 'empty input image';
return undef;
}
$img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
if ( !defined($img->{IMG}) ) {
$self->{ERRSTR} = 'unable to scale image';
return undef;
}
return $img;
}
# Transform returns a spatial transformation of the input image
# this moves pixels to a new location in the returned image.
# NOTE - should make a utility function to check transforms for
# stack overruns
sub transform {
my $self=shift;
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
my %opts=@_;
my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
# print Dumper(\%opts);
# xopcopdes
if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
if (!$I2P) {
eval ("use Affix::Infix2Postfix;");
print $@;
if ( $@ ) {
$self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
return undef;
}
$I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
{op=>'-',trans=>'Sub'},
{op=>'*',trans=>'Mult'},
{op=>'/',trans=>'Div'},
{op=>'-','type'=>'unary',trans=>'u-'},
{op=>'**'},
{op=>'func','type'=>'unary'}],
'grouping'=>[qw( \( \) )],
'func'=>[qw( sin cos )],
'vars'=>[qw( x y )]
);
}
@xt=$I2P->translate($opts{'xexpr'});
@yt=$I2P->translate($opts{'yexpr'});
$numre=$I2P->{'numre'};
@pt=(0,0);
for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
@{$opts{'parm'}}=@pt;
}
# print Dumper(\%opts);
if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
$self->{ERRSTR}='transform: no xopcodes given.';
return undef;
}
@op=@{$opts{'xopcodes'}};
for $iop (@op) {
if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
$self->{ERRSTR}="transform: illegal opcode '$_'.";
return undef;
}
push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
}
# yopcopdes
if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
$self->{ERRSTR}='transform: no yopcodes given.';
return undef;
}
@op=@{$opts{'yopcodes'}};
for $iop (@op) {
if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
$self->{ERRSTR}="transform: illegal opcode '$_'.";
return undef;
}
push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
}
#parameters
if ( !exists $opts{'parm'}) {
$self->{ERRSTR}='transform: no parameter arg given.';
return undef;
}
# print Dumper(\@ropx);
# print Dumper(\@ropy);
# print Dumper(\@ropy);
my $img = Imager->new();
$img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
return $img;
}
sub transform2 {
my ($opts, @imgs) = @_;
require "Imager/Expr.pm";
$opts->{variables} = [ qw(x y) ];
my ($width, $height) = @{$opts}{qw(width height)};
if (@imgs) {
$width ||= $imgs[0]->getwidth();
$height ||= $imgs[0]->getheight();
my $img_num = 1;
for my $img (@imgs) {
$opts->{constants}{"w$img_num"} = $img->getwidth();
$opts->{constants}{"h$img_num"} = $img->getheight();
$opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
$opts->{constants}{"cy$img_num"} = $img->getheight()/2;
++$img_num;
}
}
if ($width) {
$opts->{constants}{w} = $width;
$opts->{constants}{cx} = $width/2;
}
else {
$Imager::ERRSTR = "No width supplied";
return;
}
if ($height) {
$opts->{constants}{h} = $height;
$opts->{constants}{cy} = $height/2;
}
else {
$Imager::ERRSTR = "No height supplied";
return;
}
my $code = Imager::Expr->new($opts);
if (!$code) {
$Imager::ERRSTR = Imager::Expr::error();
return;
}
my $channels = $opts->{channels} || 3;
unless ($channels >= 1 && $channels <= 4) {
return Imager->_set_error("channels must be an integer between 1 and 4");
}
my $img = Imager->new();
$img->{IMG} = i_transform2($opts->{width}, $opts->{height},
$channels, $code->code(),
$code->nregs(), $code->cregs(),
[ map { $_->{IMG} } @imgs ]);
if (!defined $img->{IMG}) {
$Imager::ERRSTR = Imager->_error_as_msg();
return;
}
return $img;
}
sub rubthrough {
my $self=shift;
my %opts= @_;
unless ($self->{IMG}) {
$self->{ERRSTR}='empty input image';
return undef;
}
unless ($opts{src} && $opts{src}->{IMG}) {
$self->{ERRSTR}='empty input image for src';
return undef;
}
%opts = (src_minx => 0,
src_miny => 0,
src_maxx => $opts{src}->getwidth(),
src_maxy => $opts{src}->getheight(),
%opts);
my $tx = $opts{tx};
defined $tx or $tx = $opts{left};
defined $tx or $tx = 0;
my $ty = $opts{ty};
defined $ty or $ty = $opts{top};
defined $ty or $ty = 0;
unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
$opts{src_minx}, $opts{src_miny},
$opts{src_maxx}, $opts{src_maxy})) {
$self->_set_error($self->_error_as_msg());
return undef;
}
return $self;
}
sub compose {
my $self = shift;
my %opts =
(
opacity => 1.0,
mask_left => 0,
mask_top => 0,
@_
);
unless ($self->{IMG}) {
$self->_set_error("compose: empty input image");
return;
}
unless ($opts{src}) {
$self->_set_error("compose: src parameter missing");
return;
}
unless ($opts{src}{IMG}) {
$self->_set_error("compose: src parameter empty image");
return;
}
my $src = $opts{src};
my $left = $opts{left};
defined $left or $left = $opts{tx};
defined $left or $left = 0;
my $top = $opts{top};
defined $top or $top = $opts{ty};
defined $top or $top = 0;
my $src_left = $opts{src_left};
defined $src_left or $src_left = $opts{src_minx};
defined $src_left or $src_left = 0;
my $src_top = $opts{src_top};
defined $src_top or $src_top = $opts{src_miny};
defined $src_top or $src_top = 0;
my $width = $opts{width};
if (!defined $width && defined $opts{src_maxx}) {
$width = $opts{src_maxx} - $src_left;
}
defined $width or $width = $src->getwidth() - $src_left;
my $height = $opts{height};
if (!defined $height && defined $opts{src_maxy}) {
$height = $opts{src_maxy} - $src_top;
}
defined $height or $height = $src->getheight() - $src_top;
my $combine = $self->_combine($opts{combine}, 'normal');
if ($opts{mask}) {
unless ($opts{mask}{IMG}) {
$self->_set_error("compose: mask parameter empty image");
return;
}
my $mask_left = $opts{mask_left};
defined $mask_left or $mask_left = $opts{mask_minx};
defined $mask_left or $mask_left = 0;
my $mask_top = $opts{mask_top};
defined $mask_top or $mask_top = $opts{mask_miny};
defined $mask_top or $mask_top = 0;
unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
$left, $top, $src_left, $src_top,
$mask_left, $mask_top, $width, $height,
$combine, $opts{opacity})) {
$self->_set_error(Imager->_error_as_msg);
return;
}
}
else {
unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
$width, $height, $combine, $opts{opacity})) {
$self->_set_error(Imager->_error_as_msg);
return;
}
}
return $self;
}
sub flip {
my $self = shift;
my %opts = @_;
my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
my $dir;
return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
$dir = $xlate{$opts{'dir'}};
return $self if i_flipxy($self->{IMG}, $dir);
return ();
}
sub rotate {
my $self = shift;
my %opts = @_;
unless (defined wantarray) {
my @caller = caller;
warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
return;
}
if (defined $opts{right}) {
my $degrees = $opts{right};
if ($degrees < 0) {
$degrees += 360 * int(((-$degrees)+360)/360);
}
$degrees = $degrees % 360;
if ($degrees == 0) {
return $self->copy();
}
elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
my $result = Imager->new();
if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
return $result;
}
else {
$self->{ERRSTR} = $self->_error_as_msg();
return undef;
}
}
else {
$self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
return undef;
}
}
elsif (defined $opts{radians} || defined $opts{degrees}) {
my $amount = $opts{radians} || $opts{degrees} * 3.14159265358979 / 180;
my $back = $opts{back};
my $result = Imager->new;
if ($back) {
$back = _color($back);
unless ($back) {
$self->_set_error(Imager->errstr);
return undef;
}
$result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
}
else {
$result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
}
if ($result->{IMG}) {
return $result;
}
else {
$self->{ERRSTR} = $self->_error_as_msg();
return undef;
}
}
else {
$self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
return undef;
}
}
sub matrix_transform {
my $self = shift;
my %opts = @_;
unless (defined wantarray) {
my @caller = caller;
warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
return;
}
if ($opts{matrix}) {
my $xsize = $opts{xsize} || $self->getwidth;
my $ysize = $opts{ysize} || $self->getheight;
my $result = Imager->new;
if ($opts{back}) {
$result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
$opts{matrix}, $opts{back})
or return undef;
}
else {
$result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
$opts{matrix})
or return undef;
}
return $result;
}
else {
$self->{ERRSTR} = "matrix parameter required";
return undef;
}
}
# blame Leolo :)
*yatf = \&matrix_transform;
# These two are supported for legacy code only
sub i_color_new {
return Imager::Color->new(@_);
}
sub i_color_set {
return Imager::Color::set(@_);
}
# Draws a box between the specified corner points.
sub box {
my $self=shift;
my $raw = $self->{IMG};
unless ($raw) {
$self->{ERRSTR}='empty input image';
return undef;
}
my %opts = @_;
my ($xmin, $ymin, $xmax, $ymax);
if (exists $opts{'box'}) {
$xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
$xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
$ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
$ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
}
else {
defined($xmin = $opts{xmin}) or $xmin = 0;
defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
defined($ymin = $opts{ymin}) or $ymin = 0;
defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
}
if ($opts{filled}) {
my $color = $opts{'color'};
if (defined $color) {
unless (_is_color_object($color)) {
$color = _color($color);
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
}
}
else {
$color = i_color_new(255,255,255,255);
}
if ($color->isa("Imager::Color")) {
i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
}
else {
i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
}
}
elsif ($opts{fill}) {
unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
# assume it's a hash ref
require 'Imager/Fill.pm';
unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
$self->{ERRSTR} = $Imager::ERRSTR;
return undef;
}
}
i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
}
else {
my $color = $opts{'color'};
if (defined $color) {
unless (_is_color_object($color)) {
$color = _color($color);
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
}
}
else {
$color = i_color_new(255, 255, 255, 255);
}
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
}
return $self;
}
sub arc {
my $self=shift;
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
my $dflcl= [ 255, 255, 255, 255];
my $good = 1;
my %opts=
(
color=>$dflcl,
'r'=>_min($self->getwidth(),$self->getheight())/3,
'x'=>$self->getwidth()/2,
'y'=>$self->getheight()/2,
'd1'=>0, 'd2'=>361,
filled => 1,
@_,
);
if ($opts{aa}) {
if ($opts{fill}) {
unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
# assume it's a hash ref
require 'Imager/Fill.pm';
unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
}
i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
$opts{'d2'}, $opts{fill}{fill});
}
elsif ($opts{filled}) {
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
$color);
}
else {
i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
$opts{'d1'}, $opts{'d2'}, $color);
}
}
else {
my $color = _color($opts{'color'});
if ($opts{d2} - $opts{d1} >= 360) {
$good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
}
else {
$good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
}
}
}
else {
if ($opts{fill}) {
unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
# assume it's a hash ref
require 'Imager/Fill.pm';
unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
}
i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
$opts{'d2'}, $opts{fill}{fill});
}
else {
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
if ($opts{filled}) {
i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
$opts{'d1'}, $opts{'d2'}, $color);
}
else {
if ($opts{d1} == 0 && $opts{d2} == 361) {
$good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
}
else {
$good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
}
}
}
}
unless ($good) {
$self->_set_error($self->_error_as_msg);
return;
}
return $self;
}
# Draws a line from one point to the other
# the endpoint is set if the endp parameter is set which it is by default.
# to turn of the endpoint being set use endp=>0 when calling line.
sub line {
my $self=shift;
my $dflcl=i_color_new(0,0,0,0);
my %opts=(color=>$dflcl,
endp => 1,
@_);
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
$opts{antialias} = $opts{aa} if defined $opts{aa};
if ($opts{antialias}) {
i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
$color, $opts{endp});
} else {
i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
$color, $opts{endp});
}
return $self;
}
# Draws a line between an ordered set of points - It more or less just transforms this
# into a list of lines.
sub polyline {
my $self=shift;
my ($pt,$ls,@points);
my $dflcl=i_color_new(0,0,0,0);
my %opts=(color=>$dflcl,@_);
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
if (exists($opts{points})) { @points=@{$opts{points}}; }
if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
@points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
}
# print Dumper(\@points);
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
$opts{antialias} = $opts{aa} if defined $opts{aa};
if ($opts{antialias}) {
for $pt(@points) {
if (defined($ls)) {
i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
}
$ls=$pt;
}
} else {
for $pt(@points) {
if (defined($ls)) {
i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
}
$ls=$pt;
}
}
return $self;
}
sub polygon {
my $self = shift;
my ($pt,$ls,@points);
my $dflcl = i_color_new(0,0,0,0);
my %opts = (color=>$dflcl, @_);
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
if (exists($opts{points})) {
$opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
$opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
}
if (!exists $opts{'x'} or !exists $opts{'y'}) {
$self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
}
if ($opts{'fill'}) {
unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
# assume it's a hash ref
require 'Imager/Fill.pm';
unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
$self->{ERRSTR} = $Imager::ERRSTR;
return undef;
}
}
i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
$opts{'fill'}{'fill'});
}
else {
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
}
return $self;
}
# this the multipoint bezier curve
# this is here more for testing that actual usage since
# this is not a good algorithm. Usually the curve would be
# broken into smaller segments and each done individually.
sub polybezier {
my $self=shift;
my ($pt,$ls,@points);
my $dflcl=i_color_new(0,0,0,0);
my %opts=(color=>$dflcl,@_);
unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
if (exists $opts{points}) {
$opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
$opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
}
unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
$self->{ERRSTR}='Missing or invalid points.';
return;
}
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
return $self;
}
sub flood_fill {
my $self = shift;
my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
my $rc;
unless (exists $opts{'x'} && exists $opts{'y'}) {
$self->{ERRSTR} = "missing seed x and y parameters";
return undef;
}
if ($opts{border}) {
my $border = _color($opts{border});
unless ($border) {
$self->_set_error($Imager::ERRSTR);
return;
}
if ($opts{fill}) {
unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
# assume it's a hash ref
require Imager::Fill;
unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
}
$rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
$opts{fill}{fill}, $border);
}
else {
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
$rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
$color, $border);
}
if ($rc) {
return $self;
}
else {
$self->{ERRSTR} = $self->_error_as_msg();
return;
}
}
else {
if ($opts{fill}) {
unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
# assume it's a hash ref
require 'Imager/Fill.pm';
unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
}
$rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
}
else {
my $color = _color($opts{'color'});
unless ($color) {
$self->{ERRSTR} = $Imager::ERRSTR;
return;
}
$rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
}
if ($rc) {
return $self;
}
else {
$self->{ERRSTR} = $self->_error_as_msg();
return;
}
}
}
sub setpixel {
my ($self, %opts) = @_;
$self->_valid_image("setpixel")
or return;
my $color = $opts{color};
unless (defined $color) {
$color = $self->{fg};
defined $color or $color = NC(255, 255, 255);
}
unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
unless ($color = _color($color, 'setpixel')) {
$self->_set_error("setpixel: " . Imager->errstr);
return;
}
}
unless (exists $opts{'x'} && exists $opts{'y'}) {
$self->_set_error('setpixel: missing x or y parameter');
return;
}
my $x = $opts{'x'};
my $y = $opts{'y'};
if (ref $x || ref $y) {
$x = ref $x ? $x : [ $x ];
$y = ref $y ? $y : [ $y ];
unless (@$x) {
$self->_set_error("setpixel: x is a reference to an empty array");
return;
}
unless (@$y) {
$self->_set_error("setpixel: y is a reference to an empty array");
return;
}
# make both the same length, replicating the last element
if (@$x < @$y) {
$x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
}
elsif (@$y < @$x) {
$y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
}
my $set = 0;
if ($color->isa('Imager::Color')) {
for my $i (0..$#$x) {
i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
or ++$set;
}
}
else {
for my $i (0..$#$x) {
i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
or ++$set;
}
}
return $set;
}
else {
if ($color->isa('Imager::Color')) {
i_ppix($self->{IMG}, $x, $y, $color)
and return;
}
else {
i_ppixf($self->{IMG}, $x, $y, $color)
and return;
}
}
return $self;
}
sub getpixel {
my $self = shift;
my %opts = ( "type"=>'8bit', @_);
$self->_valid_image("getpixel")
or return;
unless (exists $opts{'x'} && exists $opts{'y'}) {
$self->_set_error('getpixel: missing x or y parameter');
return;
}
my $x = $opts{'x'};
my $y = $opts{'y'};
my $type = $opts{'type'};
if (ref $x || ref $y) {
$x = ref $x ? $x : [ $x ];
$y = ref $y ? $y : [ $y ];
unless (@$x) {
$self->_set_error("getpixel: x is a reference to an empty array");
return;
}
unless (@$y) {
$self->_set_error("getpixel: y is a reference to an empty array");
return;
}
# make both the same length, replicating the last element
if (@$x < @$y) {
$x = [ @$x, ($x->[-1]) x (@$y - @$x) ];
}
elsif (@$y < @$x) {
$y = [ @$y, ($y->[-1]) x (@$x - @$y) ];
}
my @result;
if ($type eq '8bit') {
for my $i (0..$#$x) {
push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
}
}
elsif ($type eq 'float' || $type eq 'double') {
for my $i (0..$#$x) {
push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
}
}
else {
$self->_set_error("getpixel: type must be '8bit' or 'float'");
return;
}
return wantarray ? @result : \@result;
}
else {
if ($type eq '8bit') {
return i_get_pixel($self->{IMG}, $x, $y);
}
elsif ($type eq 'float' || $type eq 'double') {
return i_gpixf($self->{IMG}, $x, $y);
}
else {
$self->_set_error("getpixel: type must be '8bit' or 'float'");
return;
}
}
}
sub getscanline {
my $self = shift;
my %opts = ( type => '8bit', x=>0, @_);
$self->_valid_image or return;
defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
unless (defined $opts{'y'}) {
$self->_set_error("missing y parameter");
return;
}
if ($opts{type} eq '8bit') {
return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{'y'});
}
elsif ($opts{type} eq 'float') {
return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{'y'});
}
elsif ($opts{type} eq 'index') {
unless (i_img_type($self->{IMG})) {
$self->_set_error("type => index only valid on paletted images");
return;
}
return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
$opts{'y'});
}
else {
$self->_set_error("invalid type parameter - must be '8bit' or 'float'");
return;
}
}
sub setscanline {
my $self = shift;
my %opts = ( x=>0, @_);
$self->_valid_image or return;
unless (defined $opts{'y'}) {
$self->_set_error("missing y parameter");
return;
}
if (!$opts{type}) {
if (ref $opts{pixels} && @{$opts{pixels}}) {
# try to guess the type
if ($opts{pixels}[0]->isa('Imager::Color')) {
$opts{type} = '8bit';
}
elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
$opts{type} = 'float';
}
else {
$self->_set_error("missing type parameter and could not guess from pixels");
return;
}
}
else {
# default
$opts{type} = '8bit';
}
}
if ($opts{type} eq '8bit') {
if (ref $opts{pixels}) {
return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
}
else {
return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
}
}
elsif ($opts{type} eq 'float') {
if (ref $opts{pixels}) {
return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
}
else {
return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
}
}
elsif ($opts{type} eq 'index') {
if (ref $opts{pixels}) {
return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
}
else {
return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
}
}
else {
$self->_set_error("invalid type parameter - must be '8bit' or 'float'");
return;
}
}
sub getsamples {
my $self = shift;
my %opts = ( type => '8bit', x=>0, offset => 0, @_);
defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
unless (defined $opts{'y'}) {
$self->_set_error("missing y parameter");
return;
}
if ($opts{target}) {
my $target = $opts{target};
my $offset = $opts{offset};
if ($opts{type} eq '8bit') {
my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{y}, $opts{channels})
or return;
@{$target}[$offset .. $offset + @samples - 1] = @samples;
return scalar(@samples);
}
elsif ($opts{type} eq 'float') {
my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{y}, $opts{channels});
@{$target}[$offset .. $offset + @samples - 1] = @samples;
return scalar(@samples);
}
elsif ($opts{type} =~ /^(\d+)bit$/) {
my $bits = $1;
my @data;
my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{y}, $bits, $target,
$offset, $opts{channels});
unless (defined $count) {
$self->_set_error(Imager->_error_as_msg);
return;
}
return $count;
}
else {
$self->_set_error("invalid type parameter - must be '8bit' or 'float'");
return;
}
}
else {
if ($opts{type} eq '8bit') {
return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{y}, $opts{channels});
}
elsif ($opts{type} eq 'float') {
return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{y}, $opts{channels});
}
elsif ($opts{type} =~ /^(\d+)bit$/) {
my $bits = $1;
my @data;
i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
$opts{y}, $bits, \@data, 0, $opts{channels})
or return;
return @data;
}
else {
$self->_set_error("invalid type parameter - must be '8bit' or 'float'");
return;
}
}
}
sub setsamples {
my $self = shift;
my %opts = ( x => 0, offset => 0, @_ );
unless ($self->{IMG}) {
$self->_set_error('setsamples: empty input image');
return;
}
my $data = $opts{data};
unless(defined $data) {
$self->_set_error('setsamples: data parameter missing');
return;
}
my $type = $opts{type};
defined $type or $type = '8bit';
my $width = defined $opts{width} ? $opts{width}
: $self->getwidth() - $opts{x};
my $count;
if ($type eq '8bit') {
$count = i_psamp($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
$data, $opts{offset}, $width);
}
elsif ($type eq 'float') {
$count = i_psampf($self->{IMG}, $opts{x}, $opts{y}, $opts{channels},
$data, $opts{offset}, $width);
}
elsif ($type =~ /^([0-9]+)bit$/) {
my $bits = $1;
unless (ref $data) {
$self->_set_error("setsamples: data must be an array ref for type not 8bit or float");
return;
}
$count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
$opts{channels}, $data, $opts{offset},
$width);
}
else {
$self->_set_error('setsamples: type parameter invalid');
return;
}
unless (defined $count) {
$self->_set_error(Imager->_error_as_msg);