+ if ( $input{'type'} eq 'tiff' ) {
+ $self->{IMG}=i_readtiff_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 tiff file\n";
+ return $self;
+ }
+
+ if ( $input{'type'} eq 'pnm' ) {
+ $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
+ 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 ( $input{'type'} eq 'png' ) {
+ $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
+ if ( !defined($self->{IMG}) ) {
+ $self->{ERRSTR}='unable to read png image';
+ return undef;
+ }
+ $self->{DEBUG} && print "loading a png file\n";
+ }
+
+ if ( $input{'type'} eq 'bmp' ) {
+ $self->{IMG}=i_readbmp_wiol( $IO );
+ if ( !defined($self->{IMG}) ) {
+ $self->{ERRSTR}=$self->_error_as_msg();
+ return undef;
+ }
+ $self->{DEBUG} && print "loading a bmp file\n";
+ }
+
+ if ( $input{'type'} eq 'gif' ) {
+ if ($input{colors} && !ref($input{colors})) {
+ # must be a reference to a scalar that accepts the colour map
+ $self->{ERRSTR} = "option 'colors' must be a scalar reference";
+ return undef;
+ }
+ if ($input{colors}) {
+ my $colors;
+ ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
+ if ($colors) {
+ ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
+ }
+ }
+ else {
+ $self->{IMG} =i_readgif_wiol( $IO );
+ }
+ if ( !defined($self->{IMG}) ) {
+ $self->{ERRSTR}=$self->_error_as_msg();
+ return undef;
+ }
+ $self->{DEBUG} && print "loading a gif file\n";
+ }
+
+ if ( $input{'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 ( $input{'type'} eq 'rgb' ) {
+ $self->{IMG}=i_readrgb_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 ( $input{'type'} eq 'raw' ) {
+ my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
+
+ if ( !($params{xsize} && $params{ysize}) ) {
+ $self->{ERRSTR}='missing xsize or ysize parameter for raw';
+ return undef;
+ }
+
+ $self->{IMG} = i_readraw_wiol( $IO,
+ $params{xsize},
+ $params{ysize},
+ $params{datachannels},
+ $params{storechannels},
+ $params{interleave});
+ if ( !defined($self->{IMG}) ) {
+ $self->{ERRSTR}='unable to read raw image';
+ return undef;
+ }
+ $self->{DEBUG} && print "loading a raw file\n";
+ }
+
+ } else {
+
+ # Old code for reference while changing the new stuff
+
+ if (!$input{'type'} and $input{file}) {
+ $input{'type'}=$FORMATGUESS->($input{file});
+ }
+
+ if (!$input{'type'}) {
+ $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef;
+ }
+
+ if (!$formats{$input{'type'}}) {
+ $self->{ERRSTR}='format not supported';
+ return undef;
+ }
+
+ my ($fh, $fd);
+ if ($input{file}) {
+ $fh = new IO::File($input{file},"r");
+ if (!defined $fh) {
+ $self->{ERRSTR}='Could not open file';
+ return undef;
+ }
+ binmode($fh);
+ $fd = $fh->fileno();
+ }
+
+ if ($input{fd}) {
+ $fd=$input{fd};
+ }
+
+ if ( $input{'type'} eq 'gif' ) {
+ my $colors;
+ if ($input{colors} && !ref($input{colors})) {
+ # must be a reference to a scalar that accepts the colour map
+ $self->{ERRSTR} = "option 'colors' must be a scalar reference";
+ return undef;
+ }
+ if (exists $input{data}) {
+ if ($input{colors}) {
+ ($self->{IMG}, $colors) = i_readgif_scalar($input{data});
+ } else {
+ $self->{IMG}=i_readgif_scalar($input{data});
+ }
+ } else {
+ if ($input{colors}) {
+ ($self->{IMG}, $colors) = i_readgif( $fd );
+ } else {
+ $self->{IMG} = i_readgif( $fd )
+ }
+ }
+ if ($colors) {
+ # we may or may not change i_readgif to return blessed objects...
+ ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
+ }
+ if ( !defined($self->{IMG}) ) {
+ $self->{ERRSTR}= 'reading GIF:'._error_as_msg();
+ return undef;
+ }
+ $self->{DEBUG} && print "loading a gif file\n";
+ }
+ }
+ 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;
+ 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;
+
+ 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
+
+ unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
+
+ if (!$input{'type'} and $input{file}) {
+ $input{'type'}=$FORMATGUESS->($input{file});
+ }
+ if (!$input{'type'}) {
+ $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
+ return undef;
+ }
+
+ if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
+
+ my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
+ or return undef;
+
+ # this conditional is probably obsolete
+ 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';
+ return undef;
+ }
+ } else {
+ if (!i_writetiff_wiol($self->{IMG}, $IO)) {
+ $self->{ERRSTR}='Could not write to buffer';
+ return undef;
+ }
+ }
+ } 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();
+ return undef;
+ }
+ $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';
+ $input{translate} = 'perturb';
+ $input{perturb} = $input{lmdither};
+ } elsif ($input{gifquant} eq 'gen') {
+ # just pass options through
+ } else {
+ $input{make_colors} = 'webmap'; # ignored
+ $input{translate} = 'giflib';
+ }
+ $rc = i_writegif_wiol($IO, \%input, $self->{IMG});
+ }
+
+ 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;
+ }
+
+ return $self;
+}
+
+sub write_multi {
+ my ($class, $opts, @images) = @_;
+
+ if (!$opts->{'type'} && $opts->{'file'}) {
+ $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
+ }
+ unless ($opts->{'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;
+ 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}) {
+ # assume the caller wants the same delay for each frame
+ $opts->{gif_delays} = [ ($gif_delays) x @images ];
+ }
+ my $res = i_writegif_wiol($IO, $opts, @work);
+ $res or $class->_set_error($class->_error_as_msg());
+ 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') {
+ $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
+ }
+ else {
+ $res = i_writetiff_multi_wiol($IO, @work);
+ }
+ $res or $class->_set_error($class->_error_as_msg());
+ return $res;
+ }
+ else {
+ $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
+ return 0;
+ }
+}
+
+# read multiple images from a file
+sub read_multi {
+ my ($class, %opts) = @_;
+
+ if ($opts{file} && !exists $opts{'type'}) {
+ # guess the type
+ my $type = $FORMATGUESS->($opts{file});
+ $opts{'type'} = $type;
+ }
+ unless ($opts{'type'}) {
+ $ERRSTR = "No type parameter supplied and it couldn't be guessed";
+ return;
+ }
+
+ my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
+ or return;
+ if ($opts{'type'} eq 'gif') {
+ my @imgs;
+ @imgs = i_readgif_multi_wiol($IO);
+ if (@imgs) {
+ return map {
+ bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
+ } @imgs;
+ }
+ else {
+ $ERRSTR = _error_as_msg();
+ return;
+ }
+ }
+ elsif ($opts{'type'} eq 'tiff') {
+ my @imgs = i_readtiff_multi_wiol($IO, -1);
+ if (@imgs) {
+ return map {
+ bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
+ } @imgs;
+ }
+ else {
+ $ERRSTR = _error_as_msg();
+ return;
+ }
+ }
+
+ $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
+ return;
+}
+
+# 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},%{$filters{$input{'type'}}{defaults}},%input);
+ } else {
+ %hsh=('image',$self->{IMG},%input);
+ }
+
+ my @cs=@{$filters{$input{'type'}}{callseq}};
+
+ for(@cs) {
+ if (!defined($hsh{$_})) {
+ $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
+ }
+ }
+
+ &{$filters{$input{'type'}}{callsub}}(%hsh);
+
+ my @b=keys %hsh;
+
+ $self->{DEBUG} && print "callseq is: @cs\n";
+ $self->{DEBUG} && print "matching callseq is: @b\n";
+
+ return $self;
+}
projects / imager.git / blobdiff