/usr/share/perl5/Image/Info/PPM.pm is in libimage-info-perl 1.41-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | package Image::Info::PPM;
# Copyright 2000, Gisle Aas.
#
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
=begin register
MAGIC: /^P[1-6]/
=item PBM/PGM/PPM
All information available is extracted.
=end register
=cut
use strict;
use vars qw/$VERSION/;
$VERSION = 0.04;
sub process_file {
my($info, $fh) = @_;
my @header;
my $type;
my $num_wanted = 3;
my $binary;
my $read_header;
local($/, $_) = ("\n");
while (<$fh>) {
if (s/#\s*(.*)//) {
$info->push_info(0, "Comment", $1);
}
push(@header, split(' '));
if (!$type && @header) {
$type = shift(@header);
$type =~ s/^P// || die;
$binary++ if $type > 3;
$type = "p" . qw/p b g/[$type % 3] . "m";
$num_wanted = 2 if $type eq "pbm";
}
for (@header) {
unless (/^\d+$/) {
die "Badly formatted $type file";
}
$_ += 0; # strip leading zeroes
}
next unless @header >= $num_wanted;
# Now we know everything there is to know...
$read_header = 1;
$info->push_info(0, "file_media_type" => "image/$type");
$info->push_info(0, "file_ext" => "$type");
$info->push_info(0, "width", shift @header);
$info->push_info(0, "height", shift @header);
$info->push_info(0, "resolution", "1/1");
if ($type eq "ppm") {
my $MSV = shift @header;
$info->push_info(0, "MaxSampleValue", $MSV);
$info->push_info(0, "color_type", "RGB");
$info->push_info(0, "SamplesPerPixel", 3);
if ($binary) {
for (1..3) {
$info->push_info(0, "BitsPerSample", int(log($MSV + 1) / log(2) ) );
}
}
}
else {
$info->push_info(0, "color_type", "Gray");
$info->push_info(0, "SamplesPerPixel", 1);
$info->push_info(0, "BitsPerSample", ($type eq "pbm") ? 1 : 8)
if $binary;
$info->push_info(0, "MaxSampleValue", shift @header) if $type ne 'pbm';
}
last;
}
if (!$read_header) {
$info->push_info(0, 'error' => 'Incomplete PBM/PGM/PPM header');
}
}
1;
=pod
=head1 NAME
Image::Info::PPM - PPM support Image::Info
=head1 SYNOPSIS
use Image::Info qw(image_info dim);
my $info = image_info("image.ppm");
if (my $error = $info->{error}) {
die "Can't parse image info: $error\n";
}
my($w, $h) = dim($info);
=head1 DESCRIPTION
This modules adds ppm support to L<Image::Info>.
It is loaded and used automatically.
=head1 METHODS
=head2 process_file()
$info->process_file($source, $options);
Processes one file and sets the found info fields in the C<$info> object.
=head1 AUTHOR
Gisle Aas.
=head1 LICENSE
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
|