X-Git-Url: http://git.imager.perl.org/imager.git/blobdiff_plain/cd758af25ce8daf757a4a2e4e3ee6f79ecf6453e..2e0427fdb2e4b2843346087bcdb9c5018a39086e:/Imager.pm diff --git a/Imager.pm b/Imager.pm index 15790cb8..e097fe82 100644 --- a/Imager.pm +++ b/Imager.pm @@ -94,14 +94,6 @@ use Imager::Font; ); @EXPORT=qw( - init_log - i_list_formats - i_has_format - malloc_state - i_color_new - - i_img_empty - i_img_empty_ch ); %EXPORT_TAGS= @@ -127,6 +119,13 @@ 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/; @@ -145,17 +144,13 @@ my %defaults; BEGIN { require Exporter; - @ISA = qw(Exporter); - $VERSION = '0.82_01'; - eval { - require XSLoader; - XSLoader::load(Imager => $VERSION); - 1; - } or do { - require DynaLoader; - push @ISA, 'DynaLoader'; - bootstrap Imager $VERSION; + my $ex_version = eval $Exporter::VERSION; + if ($ex_version < 5.57) { + @ISA = qw(Exporter); } + $VERSION = '0.91'; + require XSLoader; + XSLoader::load(Imager => $VERSION); } my %formats_low; @@ -451,26 +446,68 @@ sub import { } sub init_log { - i_init_log($_[0],$_[1]); - i_log_entry("Imager $VERSION starting\n", 1); + Imager->open_log(log => $_[0], level => $_[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{'log'}) { + Imager->open_log(log => $parms{log}, level => $parms{loglevel}) + or return; + } + if (exists $parms{'t1log'}) { if ($formats{t1}) { - Imager::Font::T1::i_init_t1($parms{'t1log'}); + 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 { @@ -585,11 +622,13 @@ sub _combine { } sub _valid_image { - my ($self) = @_; + my ($self, $method) = @_; $self->{IMG} and return 1; - $self->_set_error('empty input image'); + my $msg = 'empty input image'; + $msg = "$method: $msg" if $method; + $self->_set_error($msg); return; } @@ -874,8 +913,8 @@ sub img_set { $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels}); } else { - $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'}, - $hsh{'channels'}); + $self->{IMG}= i_img_8_new($hsh{'xsize'}, $hsh{'ysize'}, + $hsh{'channels'}); } unless ($self->{IMG}) { @@ -931,24 +970,40 @@ sub to_paletted { return; } + $self->_valid_image + or return; + my $result = Imager->new; - $result->{IMG} = i_img_to_pal($self->{IMG}, $opts); + unless ($result->{IMG} = i_img_to_pal($self->{IMG}, $opts)) { + $self->_set_error(Imager->_error_as_msg); + return; + } - #print "Type ", i_img_type($result->{IMG}), "\n"; + return $result; +} - if ($result->{IMG}) { - return $result; - } - else { - $self->{ERRSTR} = $self->_error_as_msg; +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 images +# convert a paletted (or any image) to an 8-bit/channel RGB image sub to_rgb8 { my $self = shift; - my $result; unless (defined wantarray) { my @caller = caller; @@ -956,30 +1011,57 @@ sub to_rgb8 { return; } - if ($self->{IMG}) { - $result = Imager->new; - $result->{IMG} = i_img_to_rgb($self->{IMG}) - or undef $result; + $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 an 8-bit/channel RGB images +# convert a paletted (or any image) to a 16-bit/channel RGB image sub to_rgb16 { my $self = shift; - my $result; unless (defined wantarray) { my @caller = caller; - warn "to_rgb16() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n"; + warn "to_rgb16() called in void context - to_rgb16() returns the converted image at $caller[1] line $caller[2]\n"; return; } - if ($self->{IMG}) { - $result = Imager->new; - $result->{IMG} = i_img_to_rgb16($self->{IMG}) - or undef $result; + $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; @@ -1268,13 +1350,17 @@ sub _get_reader_io { } sub _get_writer_io { - my ($self, $input, $type) = @_; + my ($self, $input) = @_; + + my $buffered = exists $input->{buffered} ? $input->{buffered} : 1; + my $io; + my @extras; if ($input->{io}) { - return $input->{io}; + $io = $input->{io}; } elsif ($input->{fd}) { - return io_new_fd($input->{fd}); + $io = io_new_fd($input->{fd}); } elsif ($input->{fh}) { my $fd = fileno($input->{fh}); @@ -1287,7 +1373,7 @@ sub _get_writer_io { # flush anything that's buffered, and make sure anything else is flushed $| = 1; select($oldfh); - return io_new_fd($fd); + $io = io_new_fd($fd); } elsif ($input->{file}) { my $fh = new IO::File($input->{file},"w+"); @@ -1296,28 +1382,30 @@ sub _get_writer_io { return; } binmode($fh) or die; - return (io_new_fd(fileno($fh)), $fh); + $io = io_new_fd(fileno($fh)); + push @extras, $fh; } elsif ($input->{data}) { - return io_new_bufchain(); + $io = io_new_bufchain(); } elsif ($input->{callback} || $input->{writecb}) { - if ($input->{maxbuffer}) { - return io_new_cb($input->{callback} || $input->{writecb}, - $input->{readcb}, - $input->{seekcb}, $input->{closecb}, - $input->{maxbuffer}); - } - else { - return io_new_cb($input->{callback} || $input->{writecb}, - $input->{readcb}, - $input->{seekcb}, $input->{closecb}); + 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 @@ -1335,31 +1423,39 @@ sub read { my ($IO, $fh) = $self->_get_reader_io(\%input) or return; - unless ($input{'type'}) { - $input{'type'} = i_test_format_probe($IO, -1); + 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 ($input{'type'}) { - $self->_set_error('type parameter missing and not possible to guess from extension'); + 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($input{type}); + _reader_autoload($type); - if ($readers{$input{type}} && $readers{$input{type}}{single}) { - return $readers{$input{type}}{single}->($self, $IO, %input); + if ($readers{$type} && $readers{$type}{single}) { + return $readers{$type}{single}->($self, $IO, %input); } - unless ($formats_low{$input{'type'}}) { + unless ($formats_low{$type}) { my $read_types = join ', ', sort Imager->read_types(); - $self->_set_error("format '$input{'type'}' not supported - formats $read_types available for reading"); + $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 ( $input{'type'} eq 'pnm' ) { + 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(); @@ -1369,7 +1465,7 @@ sub read { return $self; } - if ( $input{'type'} eq 'bmp' ) { + if ( $type eq 'bmp' ) { $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete ); if ( !defined($self->{IMG}) ) { $self->{ERRSTR}=$self->_error_as_msg(); @@ -1378,42 +1474,7 @@ sub read { $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{'gif_consolidate'}) { - 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 ); - } - } - else { - my $page = $input{'page'}; - defined $page or $page = 0; - $self->{IMG} = i_readgif_single_wiol( $IO, $page ); - if ($self->{IMG} && $input{colors}) { - ${ $input{colors} } = - [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ]; - } - } - - 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' ) { + 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(); @@ -1422,7 +1483,7 @@ sub read { $self->{DEBUG} && print "loading a tga file\n"; } - if ( $input{'type'} eq 'raw' ) { + if ( $type eq 'raw' ) { unless ( $input{xsize} && $input{ysize} ) { $self->_set_error('missing xsize or ysize parameter for raw'); return undef; @@ -1521,6 +1582,41 @@ sub write_types { 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; @@ -1531,50 +1627,42 @@ sub _reader_autoload { my $file = "Imager/File/\U$type\E.pm"; - unless ($attempted_to_load{$file}) { - eval { - ++$attempted_to_load{$file}; - require $file; - }; - if ($@) { - # try to get a reader specific module - my $file = "Imager/File/\U$type\EReader.pm"; - unless ($attempted_to_load{$file}) { - eval { - ++$attempted_to_load{$file}; - require $file; - }; - } + 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} || $readers{$type}; + return if $formats_low{$type} || $writers{$type}; return unless $type =~ /^\w+$/; my $file = "Imager/File/\U$type\E.pm"; - unless ($attempted_to_load{$file}) { - eval { - ++$attempted_to_load{$file}; - require $file; - }; - if ($@) { - # try to get a writer specific module - my $file = "Imager/File/\U$type\EWriter.pm"; - unless ($attempted_to_load{$file}) { - eval { - ++$attempted_to_load{$file}; - require $file; - }; - } + 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 { @@ -1693,35 +1781,36 @@ sub write { unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; } - if (!$input{'type'} and $input{file}) { - $input{'type'}=$FORMATGUESS->($input{file}); + my $type = $input{'type'}; + if (!$type and $input{file}) { + $type = $FORMATGUESS->($input{file}); } - if (!$input{'type'}) { + unless ($type) { $self->{ERRSTR}='type parameter missing and not possible to guess from extension'; return undef; } - _writer_autoload($input{type}); + _writer_autoload($type); my ($IO, $fh); - if ($writers{$input{type}} && $writers{$input{type}}{single}) { - ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'}) + if ($writers{$type} && $writers{$type}{single}) { + ($IO, $fh) = $self->_get_writer_io(\%input) or return undef; - $writers{$input{type}}{single}->($self, $IO, %input) + $writers{$type}{single}->($self, $IO, %input, type => $type) or return undef; } else { - if (!$formats_low{$input{'type'}}) { + if (!$formats_low{$type}) { my $write_types = join ', ', sort Imager->write_types(); - $self->_set_error("format '$input{'type'}' not supported - formats $write_types available for writing"); + $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, $input{'type'}) + ($IO, $fh) = $self->_get_writer_io(\%input, $type) or return undef; - - if ( $input{'type'} eq 'pnm' ) { + + if ( $type eq 'pnm' ) { $self->_set_opts(\%input, "pnm_", $self) or return undef; if ( ! i_writeppm_wiol($self->{IMG},$IO) ) { @@ -1729,7 +1818,8 @@ sub write { return undef; } $self->{DEBUG} && print "writing a pnm file\n"; - } elsif ( $input{'type'} eq 'raw' ) { + } + elsif ( $type eq 'raw' ) { $self->_set_opts(\%input, "raw_", $self) or return undef; if ( !i_writeraw_wiol($self->{IMG},$IO) ) { @@ -1737,17 +1827,8 @@ sub write { return undef; } $self->{DEBUG} && print "writing a raw 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' ) { + } + elsif ( $type eq 'bmp' ) { $self->_set_opts(\%input, "bmp_", $self) or return undef; if ( !i_writebmp_wiol($self->{IMG}, $IO) ) { @@ -1755,7 +1836,8 @@ sub write { return undef; } $self->{DEBUG} && print "writing a bmp file\n"; - } elsif ( $input{'type'} eq 'tga' ) { + } + elsif ( $type eq 'tga' ) { $self->_set_opts(\%input, "tga_", $self) or return undef; @@ -1764,24 +1846,6 @@ sub write { 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'; - } - if (!i_writegif_wiol($IO, \%input, $self->{IMG})) { - $self->{ERRSTR} = $self->_error_as_msg; - return; - } } } @@ -1881,7 +1945,9 @@ sub read_multi { } unless ($type) { - $ERRSTR = "No type parameter supplied and it couldn't be guessed"; + 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; } @@ -2566,7 +2632,7 @@ sub rotate { } } elsif (defined $opts{radians} || defined $opts{degrees}) { - my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180; + my $amount = $opts{radians} || $opts{degrees} * 3.14159265358979 / 180; my $back = $opts{back}; my $result = Imager->new; @@ -3047,6 +3113,9 @@ sub flood_fill { sub setpixel { my ($self, %opts) = @_; + $self->_valid_image("setpixel") + or return; + my $color = $opts{color}; unless (defined $color) { $color = $self->{fg}; @@ -3054,36 +3123,53 @@ sub setpixel { } unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) { - $color = _color($color) - or return undef; + unless ($color = _color($color, 'setpixel')) { + $self->_set_error("setpixel: " . Imager->errstr); + return; + } } unless (exists $opts{'x'} && exists $opts{'y'}) { - $self->{ERRSTR} = 'missing x and y parameters'; - return undef; + $self->_set_error('setpixel: missing x or y parameter'); + return; } my $x = $opts{'x'}; my $y = $opts{'y'}; - if (ref $x && ref $y) { - unless (@$x == @$y) { - $self->{ERRSTR} = 'length of x and y mismatch'; + 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..$#{$opts{'x'}}) { + for my $i (0..$#$x) { i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color) or ++$set; } } else { - for my $i (0..$#{$opts{'x'}}) { + for my $i (0..$#$x) { i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color) or ++$set; } } - $set or return; + return $set; } else { @@ -3097,7 +3183,7 @@ sub setpixel { } } - $self; + return $self; } sub getpixel { @@ -3105,41 +3191,66 @@ sub getpixel { my %opts = ( "type"=>'8bit', @_); + $self->_valid_image("getpixel") + or return; + unless (exists $opts{'x'} && exists $opts{'y'}) { - $self->{ERRSTR} = 'missing x and y parameters'; - return undef; + $self->_set_error('getpixel: missing x or y parameter'); + return; } my $x = $opts{'x'}; my $y = $opts{'y'}; - if (ref $x && ref $y) { - unless (@$x == @$y) { - $self->{ERRSTR} = 'length of x and y mismatch'; - return undef; + 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 ($opts{"type"} eq '8bit') { - for my $i (0..$#{$opts{'x'}}) { + if ($type eq '8bit') { + for my $i (0..$#$x) { push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i])); } } - else { - for my $i (0..$#{$opts{'x'}}) { + 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 ($opts{"type"} eq '8bit') { + if ($type eq '8bit') { return i_get_pixel($self->{IMG}, $x, $y); } - else { + 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; + } } - - $self; } sub getscanline { @@ -3249,24 +3360,20 @@ sub getsamples { return; } - unless ($opts{channels}) { - $opts{channels} = [ 0 .. $self->getchannels()-1 ]; - } - 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}}) + $opts{y}, $opts{channels}) or return; - @{$target}{$offset .. $offset + @samples - 1} = @samples; + @{$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; + $opts{y}, $opts{channels}); + @{$target}[$offset .. $offset + @samples - 1] = @samples; return scalar(@samples); } elsif ($opts{type} =~ /^(\d+)bit$/) { @@ -3275,7 +3382,7 @@ sub getsamples { my @data; my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width}, $opts{y}, $bits, $target, - $offset, @{$opts{channels}}); + $offset, $opts{channels}); unless (defined $count) { $self->_set_error(Imager->_error_as_msg); return; @@ -3291,18 +3398,18 @@ sub getsamples { else { if ($opts{type} eq '8bit') { return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width}, - $opts{y}, @{$opts{channels}}); + $opts{y}, $opts{channels}); } elsif ($opts{type} eq 'float') { return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width}, - $opts{y}, @{$opts{channels}}); + $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}}) + $opts{y}, $bits, \@data, 0, $opts{channels}) or return; return @data; } @@ -3322,28 +3429,44 @@ sub setsamples { return; } - unless(defined $opts{data} && ref $opts{data}) { - $self->_set_error('setsamples: data parameter missing or invalid'); + my $data = $opts{data}; + unless(defined $data) { + $self->_set_error('setsamples: data parameter missing'); return; } - unless ($opts{channels}) { - $opts{channels} = [ 0 .. $self->getchannels()-1 ]; - } + my $type = $opts{type}; + defined $type or $type = '8bit'; - unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) { - $self->_set_error('setsamples: type parameter missing or invalid'); - return; + 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); } - my $bits = $1; + 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; + } - unless (defined $opts{width}) { - $opts{width} = $self->getwidth() - $opts{x}; + $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; } - my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits, - $opts{channels}, $opts{data}, $opts{offset}, - $opts{width}); unless (defined $count) { $self->_set_error(Imager->_error_as_msg); return; @@ -3777,6 +3900,41 @@ sub get_file_limits { i_get_image_file_limits(); } +my @check_args = qw(width height channels sample_size); + +sub check_file_limits { + my $class = shift; + + my %opts = + ( + channels => 3, + sample_size => 1, + @_, + ); + + if ($opts{sample_size} && $opts{sample_size} eq 'float') { + $opts{sample_size} = length(pack("d", 0)); + } + + for my $name (@check_args) { + unless (defined $opts{$name}) { + $class->_set_error("check_file_limits: $name must be defined"); + return; + } + unless ($opts{$name} == int($opts{$name})) { + $class->_set_error("check_file_limits: $name must be a positive integer"); + return; + } + } + + my $result = i_int_check_image_file_limits(@opts{@check_args}); + unless ($result) { + $class->_set_error($class->_error_as_msg()); + } + + return $result; +} + # Shortcuts that can be exported sub newcolor { Imager::Color->new(@_); } @@ -3813,21 +3971,39 @@ sub _set_error { # Default guess for the type of an image from extension +my @simple_types = qw(png tga gif raw ico cur xpm mng jng ilbm pcx psd eps); + +my %ext_types = + ( + ( map { $_ => $_ } @simple_types ), + tiff => "tiff", + tif => "tiff", + pbm => "pnm", + pgm => "pnm", + ppm => "pnm", + pnm => "pnm", # technically wrong, but historically it works in Imager + jpeg => "jpeg", + jpg => "jpeg", + bmp => "bmp", + dib => "bmp", + rgb => "sgi", + bw => "sgi", + sgi => "sgi", + fit => "fits", + fits => "fits", + rle => "utah", + ); + sub def_guess_type { my $name=lc(shift); - my $ext; - $ext=($name =~ m/\.([^\.]+)$/)[0]; - return 'tiff' if ($ext =~ m/^tiff?$/); - return 'jpeg' if ($ext =~ m/^jpe?g$/); - return 'pnm' if ($ext =~ m/^p[pgb]m$/); - return 'png' if ($ext eq "png"); - return 'bmp' if ($ext eq "bmp" || $ext eq "dib"); - return 'tga' if ($ext eq "tga"); - return 'sgi' if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba"); - return 'gif' if ($ext eq "gif"); - return 'raw' if ($ext eq "raw"); - return lc $ext; # best guess - return (); + + my ($ext) = $name =~ /\.([^.]+)$/ + or return; + + my $type = $ext_types{$ext} + or return; + + return $type; } sub combines { @@ -3918,7 +4094,7 @@ sub Imager::ImgRaw::CLONE_SKIP { 1 } sub preload { # this serves two purposes: - # - a class method to load the file support modules included with Image + # - a class method to load the file support modules included with Imager # (or were included, once the library dependent modules are split out) # - something for Module::ScanDeps to analyze # https://rt.cpan.org/Ticket/Display.html?id=6566 @@ -3953,10 +4129,16 @@ sub _check { (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g; my $value; - if (eval { require $file; 1 }) { + my $error; + my $loaded = Imager::_load_file($file, \$error); + if ($loaded) { $value = 1; } else { + if ($error =~ /^Can't locate /) { + $error = "Can't locate $file"; + } + $reader_load_errors{$key} = $writer_load_errors{$key} = $error; $value = undef; } $self->[IX_FORMATS]{$key} = $value; @@ -4182,6 +4364,10 @@ L - using Imager's C API from Inline::C L - tools to get access to Imager's C API. +=item * + +L - brief security notes. + =back =head2 Basic Overview @@ -4251,8 +4437,13 @@ image box() - L - draw a filled or outline box. +check_file_limits() - L + circle() - L - draw a filled circle +close_log() - L - close the Imager +debugging log. + colorcount() - L - the number of colors in an image's palette (paletted images only) @@ -4265,8 +4456,8 @@ different combine type keywords compose() - L - compose one image over another. -convert() - L - -transform the color space +convert() - L - transform the color +space copy() - L - make a duplicate of an image @@ -4278,13 +4469,12 @@ used to guess the output file format based on the output file name deltag() - L - delete image tags -difference() - L - produce a -difference images from two input images. +difference() - L - produce a difference +images from two input images. -errstr() - L - the error from the last failed -operation. +errstr() - L - the error from the last failed operation. -filter() - L - image filtering +filter() - L - image filtering findcolor() - L - search the image palette, if it has one @@ -4308,9 +4498,9 @@ getcolorusage() - L getcolorusagehash() - L -get_file_limits() - L +get_file_limits() - L -getheight() - L - height of the image in +getheight() - L - height of the image in pixels getmask() - L - write mask for the image @@ -4336,11 +4526,20 @@ is_bilevel() - L - returns whether image write functions should write the image in their bilevel (blank and white, no gray levels) format +is_logging() L - test if the debug +log is active. + line() - L - draw an interval load_plugin() - L -map() - L - remap color +log() - L - send a message to the debugging +log. + +make_palette() - L - produce a +color palette from one or more input images. + +map() - L - remap color channel values masked() - L - make a masked image @@ -4363,7 +4562,9 @@ newfont() - L NF() - L -open() - L - an alias for read() +open() - L - an alias for read() + +open_log() - L - open the debug log. =for stopwords IPTC @@ -4379,9 +4580,9 @@ polyline() - L preload() - L -read() - L - read a single image from an image file +read() - L - read a single image from an image file -read_multi() - L - read multiple images from an image +read_multi() - L - read multiple images from an image file read_types() - L - list image types Imager @@ -4409,7 +4610,7 @@ scaleY() - L setcolors() - L - set palette colors in a paletted image -set_file_limits() - L +set_file_limits() - L setmask() - L @@ -4431,6 +4632,9 @@ to_rgb16() - L to_rgb8() - L +to_rgb_double() - L - convert to +double per sample image. + transform() - L transform2() - L @@ -4442,9 +4646,9 @@ unload_plugin() - L virtual() - L - whether the image has it's own data -write() - L - write an image to a file +write() - L - write an image to a file -write_multi() - L - write multiple image to an image +write_multi() - L - write multiple image to an image file. write_types() - L - list image types Imager @@ -4585,6 +4789,8 @@ saving an image - L scaling - L +security - L + SGI files - L sharpen - L, L @@ -4692,16 +4898,32 @@ Tracker. =head2 Patches -I accept patches, preferably against the main branch in subversion. -You should include an explanation of the reason for why the patch is -needed or useful. +I accept patches, preferably against the master branch in git. Please +include an explanation of the reason for why the patch is needed or +useful. Your patch should include regression tests where possible, otherwise it will be delayed until I get a chance to write them. +To browse Imager's git repository: + + http://git.imager.perl.org/imager.git + +or: + + https://github.com/tonycoz/imager + +To clone: + + git clone git://git.imager.perl.org/imager.git + +or: + + git clone git://github.com/tonycoz/imager.git + =head1 AUTHOR -Tony Cook is the current maintainer for Imager. +Tony Cook is the current maintainer for Imager. Arnar M. Hrafnkelsson is the original author of Imager. @@ -4715,9 +4937,10 @@ Imager is licensed under the same terms as perl itself. =for stopwords makeblendedfont Fontforge -A test font, FT2/fontfiles/MMOne.pfb, contains a Postscript operator -definition copyrighted by Adobe. See F in the source for -license information. +A test font, generated by the Debian packaged Fontforge, +F, contains a Postscript operator definition +copyrighted by Adobe. See F in the source for license +information. =head1 SEE ALSO @@ -4733,6 +4956,10 @@ L(3), L(3) Other perl imaging modules include: -L(3), L(3), L(3). +L(3), L(3), L(3), +L, L. + +If you're trying to use Imager for array processing, you should +probably using L. =cut