File Coverage

lib/Image/Info.pm

Criterion	Covered	Total	%
statement	94	106	88.6
branch	59	78	75.6
condition	7	11	63.6
subroutine	16	16	100.0
pod	5	5	100.0
total	181	216	83.8

#############################################################################
#
# ATTENTION! This file is autogenerated from dev/Info.pm.tmpl - DO NOT EDIT!
#
#############################################################################

package Image::Info;

# Copyright 1999-2004, Gisle Aas.
#
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl v5.8.8 itself.
#
# Previously maintained by Tels - (c) 2006 - 2008.
# Currently maintained by Slaven Rezic - (c) 2008 - 2022.

use strict;
use vars qw($VERSION @EXPORT_OK);

$VERSION = '1.43';

require Exporter;
*import = \&Exporter::import;

@EXPORT_OK = qw(image_info dim html_dim image_type determine_file_format);

# already required and failed sub-modules are remembered here
my %mod_failure;

sub image_info
{
    my $source = _source(shift);
    return $source if ref $source eq 'HASH'; # Pass on errors

    # What sort of file is it?
    my $head = _head($source);

    return $head if ref($head) eq 'HASH';	# error?

    my $format = determine_file_format($head)
        or return { error => 'Unrecognized file format' };

    return _image_info_for_format($format, $source);
}

# Note: this function is private, but may be used by Image::Info::*
# implementations (i.e. the WBMP implementation)
sub _image_info_for_format
{
    my($format, $source) = @_;

    my $mod = "Image::Info::$format";
    my $sub = "$mod\::process_file";
    my $info = bless [], "Image::Info::Result";
    eval {
        unless (defined &$sub) {
	    # already required and failed?
            if (my $fail = $mod_failure{$mod}) {
                die $fail;
            }
            eval "require $mod";
            if ($@) {
                $mod_failure{$mod} = $@;
                die $@;
            }
            die "$mod did not define &$sub" unless defined &$sub;
        }

        my %cnf = @_;
        {
	    # call process_file()
	    no strict 'refs';
	    &$sub($info, $source, \%cnf);
	}
        $info->clean_up;
    };
    return { error => $@ } if $@;
    return wantarray ? @$info : $info->[0];
}

sub image_type
{
    my $source = _source(shift);
    return $source if ref $source eq 'HASH'; # Pass on errors

    # What sort of file is it?
    my $head = _head($source) or return _os_err("Can't read head");
    my $format = determine_file_format($head)
        or return { error => "Unrecognized file format" };

    return { file_type => $format };
}

# Note: this function is private, but may be used by Image::Info::*
# implementations (i.e. the WBMP implementation)
sub _source
{
    my $source = shift;
    if (!ref $source) {
	my $fh;
	if ($] < 5.006) {
	    require Symbol;
	    $fh = Symbol::gensym();
	    open($fh, $source) || return _os_err("Can't open $source");
	}
	else {
	    open $fh, '<', $source
		or return _os_err("Can't open $source");
	}
	${*$fh} = $source;  # keep filename in case somebody wants to know
        binmode($fh);
        $source = $fh;
    }
    elsif (ref($source) eq "SCALAR") {
	# Earlier PerlIO::scalar versions may segfault or consume lots
	# of memory for some invalid images, see
	# RT #100847 and img/segfault.tif
	if (eval { require PerlIO::scalar; PerlIO::scalar->VERSION(0.21) } ||
	    !eval { require IO::Scalar; 1 }) {
	    open(my $s, "<", $source) or return _os_err("Can't open string");
	    $source = $s;
	}
	else {
	    $source = IO::Scalar->new($source);
	}
    }
    else {
	seek($source, 0, 0) or return _os_err("Can't rewind");
    }

    $source;
}

sub _head
{
    my $source = shift;
    my $head;

    # Originally was 32 bytes.
    # In the meantime lowered to 11 bytes.
    # But XBM probably need more because of a leading comment.
    my $to_read = 64;
    my $read = read($source, $head, $to_read);

    return _os_err("Couldn't read any bytes") if !$read;

    if (ref($source) eq "IO::String") {
	# XXX workaround until we can trap seek() with a tied file handle
	$source->setpos(0);
    }
    else {
	seek($source, 0, 0) or return _os_err("Can't rewind");
    }
    $head;
}

sub _os_err
{
    return { error => "$_[0]: $!",
	     Errno => $!+0,
	   };
}

sub determine_file_format
{
   local($_) = @_;
   return "JPEG" if /^\xFF\xD8/;
   return "PNG" if /^\x89PNG\x0d\x0a\x1a\x0a/;
   return "GIF" if /^GIF8[79]a/;
   return "TIFF" if /^MM\x00\x2a/;
   return "TIFF" if /^II\x2a\x00/;
   return "BMP" if /^BM/;
   return "ICO" if /^\000\000\001\000/;
   return "PPM" if /^P[1-6]/;
   return "XPM" if /(^\/\* XPM \*\/)|(static\s+char\s+\*\w+\[\]\s*=\s*{\s*"\d+)/;
   return "XBM" if /^(?:\/\*.*\*\/\n)?#define\s/;
   return "SVG" if /^(<\?xml|[\012\015\t ]*
   return "WEBP" if /^RIFF.{4}WEBP/s;
   return undef;
}

sub dim
{
    my $img = shift || return;
    my $x = $img->{width} || return;
    my $y = $img->{height} || return;
    wantarray ? ($x, $y) : "${x}x$y";
}

sub html_dim
{
    my($x, $y) = dim(@_);
    return "" unless $x;
    "width=\"$x\" height=\"$y\"";
}

#############################################################################
package Image::Info::Result;

sub push_info
{
    my($self, $n, $key) = splice(@_, 0, 3);
    push(@{$self->[$n]{$key}}, @_);
}

sub replace_info
{
    my($self, $n, $key) = splice(@_, 0, 3);
    $self->[$n]{$key}[0] = $_[0];
}

sub clean_up
{
    my $self = shift;
    for (@$self) {
	for my $k (keys %$_) {
	    my $a = $_->{$k};
	    $_->{$k} = $a->[0] if @$a <= 1;
	}
    }
}

sub get_info {
    my($self, $n, $key, $delete) = @_;
    my $v = $delete ? delete $self->[$n]{$key} : $self->[$n]{$key};
    $v ||= [];
    @$v;
}

1;

__END__