File Coverage

lib/Image/Info/XPM.pm

Criterion	Covered	Total	%
statement	28	70	40.0
branch	3	30	10.0
condition			n/a
subroutine	3	5	60.0
pod	1	1	100.0
total	35	106	33.0

package Image::Info::XPM;
$VERSION = '1.09';
use strict;
use Image::Xpm 1.09;


sub process_file{
    my($info, $source, $opts) = @_;

    local $SIG{__WARN__} = sub {
	$info->push_info(0, "Warn", shift);
    };

    my $i = Image::Xpm->new(-width => 0, -height => 0);
    # loading the file as a separate step avoids a "-r" test, this would
    # file with in-memory strings (aka fake files)
    $i->load($source);

    $info->push_info(0, "color_type" => "Indexed-RGB");
    $info->push_info(0, "file_ext" => "xpm");
    $info->push_info(0, "file_media_type" => "image/x-xpixmap");
    $info->push_info(0, "height", $i->get(-height));
    $info->push_info(0, "resolution", "1/1");
    $info->push_info(0, "width", $i->get(-width));
    $info->push_info(0, "BitsPerSample" => 8);
    $info->push_info(0, "SamplesPerPixel", 1);

    $info->push_info(0, "XPM_CharactersPerPixel" => $i->get(-cpp) );
    # XXX is this always?
    $info->push_info(0, "ColorResolution", 8);
    $info->push_info(0, "ColorTableSize" => $i->get(-ncolours) );
    if( $opts->{ColorPalette} ){
	$info->push_info(0, "ColorPalette" => [keys %{$i->get(-cindex)}] );
    }
    if( $opts->{L1D_Histogram} ){
	#Do Histograms
	my(%RGB, @l1dhist, $R, $G, $B, $color);
	for(my $y=0; $y<$i->get(-height); $y++){
	    for(my $x=0; $x<$i->get(-width); $x++){
		$color = $i->xy($x, $y);
		if( $color =~ /^(none|opaque)$/i ) {
		    next;
		} elsif( $color !~ /^#/ ){
		    unless( exists($RGB{white}) ){
			local $_;
			if( open(RGB, _get_rgb_txt()) ){
			    while(){
				next if /^\s*!/;
				/(\d+)\s+(\d+)\s+(\d+)\s+(.*)/;
				$RGB{$4}=[$1,$2,$3];
			    }
			}
			else{
			    $RGB{white} = "0 but true";
			    $info->push_info(0, "Warn", "Unable to open RGB database, you may need to set \$Image::Info::XPM::RGBLIB");
			}
		    }
		    $R = $RGB{$color}->[0];
		    $G = $RGB{$color}->[1];
		    $B = $RGB{$color}->[2];
		}
		elsif (length $color == 7) {
		    $R = hex(substr($color,1,2));
		    $G = hex(substr($color,3,2));
		    $B = hex(substr($color,5,2));
		}
		elsif (length $color == 13) {
		    $R = hex(substr($color,1,2));
		    $G = hex(substr($color,5,2));
		    $B = hex(substr($color,9,2));
		}
		elsif (length $color == 4) {
		    $R = hex(substr($color,1,1))*16;
		    $G = hex(substr($color,2,1))*16;
		    $B = hex(substr($color,3,1))*16;
		}
		else {
		    warn "Unexpected length in color specification '$color'";
		}
		if( $opts->{L1D_Histogram} ){
		    $l1dhist[(.3*$R + .59*$G + .11*$B)]++;
		}
	    }
	}
	if( $opts->{L1D_Histogram} ){
	    $info->push_info(0, "L1D_Histogram", [@l1dhist]);
	}
    }
    $info->push_info(0, "HotSpotX" => $i->get(-hotx) );
    $info->push_info(0, "HotSpotY" => $i->get(-hoty) );
    $info->push_info(0, 'XPM_Extension-'.ucfirst($i->get(-extname)) => $i->get(-extlines)) if
	$i->get(-extname);

    for (@{$i->get(-comments)}) {
	$info->push_info(0, "Comment", $_);
    }
}

sub _get_rgb_txt{
    return $Image::Info::XPM::RGBLIB if defined $Image::Info::XPM::RGBLIB;
    # list taken from Tk::ColorEditor
    for my $try(
	'/usr/local/lib/X11/rgb.txt',
	'/usr/lib/X11/rgb.txt',
	'/usr/X11R6/lib/X11/rgb.txt',
	'/usr/local/X11R5/lib/X11/rgb.txt',
	'/X11/R5/lib/X11/rgb.txt',
	'/X11/R4/lib/rgb/rgb.txt',
	'/usr/openwin/lib/X11/rgb.txt',
	'/usr/share/X11/rgb.txt', # This is the Debian and RH5 location
	'/usr/X11/share/X11/rgb.txt', # seen on a Mac OS X 10.5.1 system
	'/usr/X11R6/share/X11/rgb.txt', # seen on a OpenBSD 4.2 system
	'/etc/X11R6/rgb.txt',
	'/etc/X11/rgb.txt', # seen on HP-UX 11.31
    ){
	if( -r $try ){
	    $Image::Info::XPM::RGBLIB = $try;
	    return $try;
	}
    }
    undef;
}

1;
__END__