package Imager;
use strict;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS $warn_obsolete);
use IO::File;
use Imager::Color;
i_img_setmask
i_img_getmask
- i_draw
+ i_line
i_line_aa
i_box
i_box_filled
require Exporter;
require DynaLoader;
- $VERSION = '0.39';
+ $VERSION = '0.41';
@ISA = qw(Exporter DynaLoader);
bootstrap Imager $VERSION;
}
};
$FORMATGUESS=\&def_guess_type;
+
+ $warn_obsolete = 1;
}
#
# print Dumper(@_);
#}
+sub init_log {
+ m_init_log($_[0],$_[1]);
+ log_entry("Imager $VERSION starting\n", 1);
+}
+
+
sub init {
my %parms=(loglevel=>1,@_);
if ($parms{'log'}) {
init_log($parms{'log'},$parms{'loglevel'});
}
+ if (exists $parms{'warn_obsolete'}) {
+ $warn_obsolete = $parms{'warn_obsolete'};
+ }
+
# if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
# if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
# i_init_fonts();
# $fontstate='ok';
# }
+ if (exists $parms{'t1log'}) {
+ i_init_fonts($parms{'t1log'});
+ }
}
END {
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) {
$result = $arg;
}
else {
- if ($arg =~ /^HASH\(/) {
+ if ($copy =~ /^HASH\(/) {
$result = Imager::Color->new(%$arg);
}
- elsif ($arg =~ /^ARRAY\(/) {
+ elsif ($copy =~ /^ARRAY\(/) {
if (grep $_ > 1, @$arg) {
$result = Imager::Color->new(@$arg);
}
}
}
+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;
+ }
+}
+
my @needseekcb = qw/tiff/;
my %needseekcb = map { $_, $_ } @needseekcb;
$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);
return io_new_fd($fd);
}
elsif ($input->{file}) {
return $self;
}
+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',
+ );
+
+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 (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;
fax_fine=>1, @_);
my $rc;
+ $self->_set_opts(\%input, "i_", $self)
+ or return undef;
+
my %iolready=( tiff=>1, raw=>1, png=>1, pnm=>1, bmp=>1, jpeg=>1, tga=>1,
gif=>1 ); # this will be SO MUCH BETTER once they are all in there
if ($iolready{$input{'type'}}) {
if ($input{'type'} eq 'tiff') {
+ $self->_set_opts(\%input, "tiff_", $self)
+ or return undef;
+ $self->_set_opts(\%input, "exif_", $self)
+ or return undef;
+
if (defined $input{class} && $input{class} eq 'fax') {
if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
$self->{ERRSTR}='Could not write to buffer';
}
}
} elsif ( $input{'type'} eq 'pnm' ) {
+ $self->_set_opts(\%input, "pnm_", $self)
+ or return undef;
if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
$self->{ERRSTR}='unable to write pnm image';
return undef;
}
$self->{DEBUG} && print "writing a pnm file\n";
} elsif ( $input{'type'} eq 'raw' ) {
+ $self->_set_opts(\%input, "raw_", $self)
+ or return undef;
if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
$self->{ERRSTR}='unable to write raw image';
return undef;
}
$self->{DEBUG} && print "writing a raw file\n";
} elsif ( $input{'type'} eq 'png' ) {
+ $self->_set_opts(\%input, "png_", $self)
+ or return undef;
if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
$self->{ERRSTR}='unable to write png image';
return undef;
}
$self->{DEBUG} && print "writing a png file\n";
} elsif ( $input{'type'} eq 'jpeg' ) {
+ $self->_set_opts(\%input, "jpeg_", $self)
+ or return undef;
+ $self->_set_opts(\%input, "exif_", $self)
+ or return undef;
if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
$self->{ERRSTR} = $self->_error_as_msg();
return undef;
}
$self->{DEBUG} && print "writing a jpeg file\n";
} elsif ( $input{'type'} eq 'bmp' ) {
+ $self->_set_opts(\%input, "bmp_", $self)
+ or return undef;
if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
$self->{ERRSTR}='unable to write bmp image';
return undef;
}
$self->{DEBUG} && print "writing a bmp file\n";
} elsif ( $input{'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();
}
$self->{DEBUG} && print "writing a tga file\n";
} elsif ( $input{'type'} eq 'gif' ) {
+ $self->_set_opts(\%input, "gif_", $self)
+ or return undef;
# compatibility with the old interfaces
if ($input{gifquant} eq 'lm') {
$input{make_colors} = 'addi';
$class->_set_error('Usage: Imager->write_multi({ options }, @images)');
return 0;
}
+ $class->_set_opts($opts, "i_", @images)
+ or return;
my @work = map $_->{IMG}, @images;
my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
or return undef;
if ($opts->{'type'} eq 'gif') {
+ $class->_set_opts($opts, "gif_", @images)
+ or return;
my $gif_delays = $opts->{gif_delays};
local $opts->{gif_delays} = $gif_delays;
if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
return $res;
}
elsif ($opts->{'type'} eq 'tiff') {
+ $class->_set_opts($opts, "tiff_", @images)
+ or return;
+ $class->_set_opts($opts, "exif_", @images)
+ or return;
my $res;
$opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
return $self;
}
-# Draws a line from one point to (but not including) the destination point
+# 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,@_);
+ 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;
+ 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);
+ i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
+ $color, $opts{endp});
} else {
- i_draw($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
- $color);
+ i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
+ $color, $opts{endp});
}
return $self;
}
if ($opts{antialias}) {
for $pt(@points) {
if (defined($ls)) {
- i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
+ 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_draw($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color);
+ i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
}
$ls=$pt;
}
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;
}
}
- i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
+ $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;
+ unless ($color) {
+ $self->{ERRSTR} = $Imager::ERRSTR;
+ return;
}
- i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
+ $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
}
-
- $self;
+ if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
}
sub setpixel {
or return undef;
if (ref $x && ref $y) {
unless (@$x == @$y) {
- $self->{ERRSTR} = 'length of x and y mistmatch';
+ $self->{ERRSTR} = 'length of x and y mismatch';
return undef;
}
if ($color->isa('Imager::Color')) {
sub getpixel {
my $self = shift;
- my %opts = ( type=>'8bit', @_);
+ my %opts = ( "type"=>'8bit', @_);
unless (exists $opts{'x'} && exists $opts{'y'}) {
$self->{ERRSTR} = 'missing x and y parameters';
return undef;
}
my @result;
- if ($opts{type} eq '8bit') {
+ if ($opts{"type"} eq '8bit') {
for my $i (0..$#{$opts{'x'}}) {
push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
}
return wantarray ? @result : \@result;
}
else {
- if ($opts{type} eq '8bit') {
+ if ($opts{"type"} eq '8bit') {
return i_get_pixel($self->{IMG}, $x, $y);
}
else {
return $self;
}
+sub difference {
+ my ($self, %opts) = @_;
+
+ defined $opts{mindist} or $opts{mindist} = 0;
+
+ defined $opts{other}
+ or return $self->_set_error("No 'other' parameter supplied");
+ defined $opts{other}{IMG}
+ or return $self->_set_error("No image data in 'other' image");
+
+ $self->{IMG}
+ or return $self->_set_error("No image data");
+
+ my $result = Imager->new;
+ $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
+ $opts{mindist})
+ or return $self->_set_error($self->_error_as_msg());
+
+ return $result;
+}
+
# destructive border - image is shrunk by one pixel all around
sub border {
else {
$ERRSTR = $msg;
}
+ return;
}
# Default guess for the type of an image from extension
}
- # Logo Generator Example
-
=head1 DESCRIPTION
=item Imager::ImageTypes
+Basics of constructing image objects with C<new()>:
Direct type/virtual images, RGB(A)/paletted images, 8/16/double
bits/channel, color maps, channel masks, image tags, color
-quantization.
+quantization. Also discusses basic image information methods.
=item Imager::Files
Color specification.
-=item Imager::Color
+=item Imager::Fill
Fill pattern specification.
=item Imager::Engines
-transform2 and matrix_transform.
+Programmable transformations through C<transform()>, C<transform2()>
+and C<matrix_transform()>.
=item Imager::Filters
-
-
=head2 Basic Overview
-An Image object is created with C<$img = Imager-E<gt>new()> Should
-this fail for some reason an explanation can be found in
-C<$Imager::ERRSTR> usually error messages are stored in
-C<$img-E<gt>{ERRSTR}>, but since no object is created this is the only
-way to give back errors. C<$Imager::ERRSTR> is also used to report
-all errors not directly associated with an image object. Examples:
+An Image object is created with C<$img = Imager-E<gt>new()>.
+Examples:
- $img=Imager->new(); # This is an empty image (size is 0 by 0)
- $img->open(file=>'lena.png',type=>'png'); # initializes from file
+ $img=Imager->new(); # create empty image
+ $img->open(file=>'lena.png',type=>'png') or # read image from file
+ die $img->errstr(); # give an explanation
+ # if something failed
or if you want to create an empty image:
This example creates a completely black image of width 400 and height
300 and 4 channels.
+When an operation fails which can be directly associated with an image
+the error message is stored can be retrieved with
+C<$img-E<gt>errstr()>.
+
+In cases where no image object is associated with an operation
+C<$Imager::ERRSTR> is used to report errors not directly associated
+with an image object.
+
+The C<Imager-><gt>new> method is described in detail in the
+Imager::ImageTypes manpage.
+=head1 SUPPORT
+You can ask for help, report bugs or express your undying love for
+Imager on the Imager-devel mailing list.
+
+To subscribe send a message with C<subscribe> in the body to:
+
+ imager-devel+request@molar.is
+
+or use the form at:
+
+ http://www.molar.is/en/lists/imager-devel/
+ (annonymous is temporarily off due to spam)
+
+where you can also find the mailing list archive.
+
+If you're into IRC, you can typically find the developers in #Imager
+on irc.rhizomatic.net. As with any IRC channel, the participants
+could be occupied or asleep, so please be patient.
=head1 BUGS
=head1 AUTHOR
-Arnar M. Hrafnkelsson (addi@umich.edu) and Tony Cook (XXX) See the
-README for a complete list.
+Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
+(tony@imager.perl.org) See the README for a complete list.
=head1 SEE ALSO
-perl(1), Imager::Color(3), Imager::Font(3), Imager::Matrix2d(3),
-Affix::Infix2Postfix(3), Parse::RecDescent(3)
+perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
+Imager::Color(3), Imager::Fill(3), Imager::Font(3),
+Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
+Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
+
+Affix::Infix2Postfix(3), Parse::RecDescent(3)
http://www.eecs.umich.edu/~addi/perl/Imager/
=cut
+
+
+
+
projects / imager.git / blobdiff