1package Image::Info::PNG;
2
3# Copyright 1999-2000, Gisle Aas.
4#
5# This library is free software; you can redistribute it and/or
6# modify it under the same terms as Perl itself.
7
8=begin register
9
10MAGIC: /^\x89PNG\x0d\x0a\x1a\x0a/
11
12Information from IHDR, PLTE, gAMA, pHYs, tEXt, tIME chunks are
13extracted.  The sequence of chunks are also given by the C<PNG_Chunks>
14key.
15
16=end register
17
18=cut
19
20use strict;
21
22# Test for Compress::Zlib (for reading zTXt chunks)
23my $have_zlib = 0;
24eval {
25    require Compress::Zlib;
26    $have_zlib++;
27};
28
29sub my_read
30{
31    my($source, $len) = @_;
32    my $buf;
33    my $n = read($source, $buf, $len);
34    die "read failed: $!" unless defined $n;
35    die "short read ($len/$n)" unless $n == $len;
36    $buf;
37}
38
39
40sub process_file
41{
42    my($info, $fh) = @_;
43
44    my $signature = my_read($fh, 8);
45    die "Bad PNG signature"
46	unless $signature eq "\x89PNG\x0d\x0a\x1a\x0a";
47
48    $info->push_info(0, "file_media_type" => "image/png");
49    $info->push_info(0, "file_ext" => "png");
50
51    my @chunks;
52
53    while (1) {
54        my($len, $type) = unpack("Na4", my_read($fh, 8));
55
56	if (@chunks) {
57	    my $last = $chunks[-1];
58	    $last =~ s/\s(\d+)$//;
59	    my $count = $1 || 1;
60	    if ($last eq $type) {
61		$count++;
62		$chunks[-1] = "$type $count";
63	    }
64	    else {
65		push(@chunks, $type);
66	    }
67	}
68	else {
69	    push(@chunks, $type);
70	}
71
72        last if $type eq "IEND";
73        my $data = my_read($fh, $len + 4);
74	my $crc = unpack("N", substr($data, -4, 4, ""));
75	if ($type eq "IHDR" && $len == 13) {
76	    my($w, $h, $depth, $ctype, $compression, $filter, $interlace) =
77		unpack("NNCCCCC", $data);
78	    $ctype = {
79		      0 => "Gray",
80		      2 => "RGB",
81		      3 => "Indexed-RGB",
82		      4 => "GrayA",
83		      6 => "RGBA",
84		     }->{$ctype} || "PNG-$ctype";
85
86	    $compression = "Deflate" if $compression == 0;
87	    $filter = "Adaptive" if $filter == 0;
88	    $interlace = "Adam7" if $interlace == 1;
89
90	    $info->push_info(0, "width", $w);
91	    $info->push_info(0, "height", $h);
92	    $info->push_info(0, "SampleFormat", "U$depth");
93	    $info->push_info(0, "color_type", $ctype);
94
95	    $info->push_info(0, "Compression", $compression);
96	    $info->push_info(0, "PNG_Filter", $filter);
97	    $info->push_info(0, "Interlace", $interlace)
98		if $interlace;
99	}
100	elsif ($type eq "PLTE") {
101	    my @table;
102	    while (length $data) {
103		push(@table, sprintf("#%02x%02x%02x",
104				     unpack("C3", substr($data, 0, 3, ""))));
105	    }
106	    $info->push_info(0, "ColorPalette" => \@table);
107	}
108	elsif ($type eq "gAMA" && $len == 4) {
109	    $info->push_info(0, "Gamma", unpack("N", $data)/100_000);
110	}
111	elsif ($type eq "pHYs" && $len == 9) {
112	    my $res;
113	    my($res_x, $res_y, $unit) = unpack("NNC", $data);
114	    if (0 && $unit == 1) {
115		# convert to dpi
116		$unit = "dpi";
117		for ($res_x, $res_y) {
118		    $_ *= 0.0254;
119		}
120	    }
121	    $res = ($res_x == $res_y) ? $res_x : "$res_x/$res_y";
122	    if ($unit) {
123		if ($unit == 1) {
124		    $res .= " dpm";
125		}
126		else {
127		    $res .= " png-unit-$unit";
128		}
129	    }
130	    $info->push_info(0, "resolution" => $res)
131	}
132	elsif ($type eq "tEXt") {
133	    my($key, $val) = split(/\0/, $data, 2);
134	    # XXX should make sure $key is not in conflict with any
135	    # other key we might generate
136	    $info->push_info(0, $key, $val);
137	}
138	elsif ($type eq "zTXt" && $have_zlib) {
139		my($key, $val) = split(/\0/, $data, 2);
140		my($method,$ctext) = split(//, $val, 2);
141		if ($method == 0) {
142		    $info->push_info(0, $key, Compress::Zlib::uncompress($ctext));
143		} else {
144		    $info->push_info(0, "Chunk-$type" => $data);
145		}
146	}
147	elsif ($type eq "tIME" && $len == 7) {
148	    $info->push_info(0, "LastModificationTime",
149			     sprintf("%04d-%02d-%02d %02d:%02d:%02d",
150				     unpack("nC5", $data)));
151	}
152	elsif ($type eq "sBIT") {
153	    $info->push_info(0, "SignificantBits" => unpack("C*", $data));
154	}
155	elsif ($type eq "IDAT") {
156	    # ignore
157	}
158	else {
159	    $info->push_info(0, "Chunk-$type" => $data);
160	}
161    }
162
163    $info->push_info(0, "PNG_Chunks", @chunks);
164
165    unless ($info->get_info(0, "resolution")) {
166	$info->push_info(0, "resolution", "1/1");
167    }
168}
169
1701;
171