line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
########################################################### |
2
|
|
|
|
|
|
|
# A Perl package for showing/modifying JPEG (meta)data. # |
3
|
|
|
|
|
|
|
# Copyright (C) 2004,2005,2006 Stefano Bettelli # |
4
|
|
|
|
|
|
|
# See the COPYING and LICENSE files for license terms. # |
5
|
|
|
|
|
|
|
########################################################### |
6
|
15
|
|
|
15
|
|
67
|
use Image::MetaData::JPEG::data::Tables qw(:TagsAPP13); |
|
15
|
|
|
|
|
17
|
|
|
15
|
|
|
|
|
1897
|
|
7
|
15
|
|
|
15
|
|
69
|
no integer; |
|
15
|
|
|
|
|
17
|
|
|
15
|
|
|
|
|
63
|
|
8
|
15
|
|
|
15
|
|
268
|
use strict; |
|
15
|
|
|
|
|
18
|
|
|
15
|
|
|
|
|
355
|
|
9
|
15
|
|
|
15
|
|
56
|
use warnings; |
|
15
|
|
|
|
|
17
|
|
|
15
|
|
|
|
|
7045
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
########################################################### |
12
|
|
|
|
|
|
|
# This routine dumps the Adobe identifier and then enters # |
13
|
|
|
|
|
|
|
# a loop on the resource data block dumper, till the end. # |
14
|
|
|
|
|
|
|
# TODO: implement dumping of multiple blocks!!!! # |
15
|
|
|
|
|
|
|
########################################################### |
16
|
|
|
|
|
|
|
sub dump_app13 { |
17
|
97
|
|
|
97
|
0
|
99
|
my ($this) = @_; |
18
|
|
|
|
|
|
|
# get a reference to the segment record list |
19
|
97
|
|
|
|
|
123
|
my $records = $this->{records}; |
20
|
|
|
|
|
|
|
# the segment always starts with an Adobe identifier |
21
|
97
|
50
|
|
|
|
191
|
$this->die('Identifier not found') unless |
22
|
|
|
|
|
|
|
my $id = $this->search_record_value('Identifier'); |
23
|
97
|
|
|
|
|
274
|
$this->set_data($id); |
24
|
|
|
|
|
|
|
# version 2.5 (old) is followed by eight undocumented bytes |
25
|
|
|
|
|
|
|
# (maybe resolution info): output them if present and valid |
26
|
97
|
|
|
|
|
199
|
my $rec = $this->search_record('Resolution'); |
27
|
97
|
50
|
|
|
|
295
|
$this->die('Header problem') unless (defined $rec) eq ($id =~ /2\.5/); |
28
|
97
|
50
|
|
|
|
159
|
$this->set_data($rec->get_value()) if $rec; |
29
|
|
|
|
|
|
|
# for each possible IPTC record number (remember that there can be |
30
|
|
|
|
|
|
|
# multiple IPTC subdirs, referring to different IPTC records), dump |
31
|
|
|
|
|
|
|
# the corresponding IPTC block, if present; the easiest solution is |
32
|
|
|
|
|
|
|
# to create a fake Record, which is then dumped as usual |
33
|
97
|
|
|
|
|
167
|
for my $r_number (1..9) { |
34
|
873
|
100
|
|
|
|
2137
|
next unless my $record |
35
|
|
|
|
|
|
|
= $this->search_record("${APP13_IPTC_DIRNAME}_${r_number}"); |
36
|
98
|
|
|
|
|
197
|
my $content = $record->get_value(); |
37
|
98
|
|
|
|
|
220
|
my $block = dump_IPTC_datasets($r_number, $content); |
38
|
98
|
|
|
|
|
297
|
my $fake_record = new Image::MetaData::JPEG::Record |
39
|
|
|
|
|
|
|
($APP13_PHOTOSHOP_IPTC, $UNDEF, \ $block, length $block); |
40
|
98
|
|
|
|
|
142
|
$fake_record->{extra} = $record->{extra}; |
41
|
98
|
|
|
|
|
216
|
$this->dump_resource_data_block($fake_record); } |
42
|
|
|
|
|
|
|
# do the same on all non-IPTC subdirs (remember that there can be |
43
|
|
|
|
|
|
|
# multiple non-IPTC subdirs, with type '8BIM', '8BPS', 'PHUT', ...) |
44
|
97
|
|
|
|
|
175
|
for my $type (@$APP13_PHOTOSHOP_TYPE) { |
45
|
291
|
100
|
|
|
|
795
|
next unless my $record |
46
|
|
|
|
|
|
|
= $this->search_record("${APP13_PHOTOSHOP_DIRNAME}_${type}"); |
47
|
86
|
|
|
|
|
94
|
$this->dump_resource_data_block($_,$type) for @{$record->get_value()};} |
|
86
|
|
|
|
|
174
|
|
48
|
|
|
|
|
|
|
# return without errors |
49
|
97
|
|
|
|
|
276
|
return undef; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
########################################################### |
53
|
|
|
|
|
|
|
# TODO: implement dumping of multiple blocks!!!! # |
54
|
|
|
|
|
|
|
########################################################### |
55
|
|
|
|
|
|
|
sub dump_resource_data_block { |
56
|
1399
|
|
|
1399
|
0
|
1231
|
my ($this, $record, $type) = @_; |
57
|
|
|
|
|
|
|
# try to extract an optional name from the extra field |
58
|
1399
|
100
|
|
|
|
1871
|
my $name = $record->{extra} ? $record->{extra} : ''; |
59
|
|
|
|
|
|
|
# provide a default type if $type is null |
60
|
1399
|
100
|
|
|
|
1764
|
$type = $$APP13_PHOTOSHOP_TYPE[0] unless $type; |
61
|
|
|
|
|
|
|
# dump the resource data block type |
62
|
1399
|
|
|
|
|
2071
|
$this->set_data($type); |
63
|
|
|
|
|
|
|
# dump the block identifier, which is the numeric tag |
64
|
|
|
|
|
|
|
# of the record (as a 2-byte unsigned integer). |
65
|
1399
|
|
|
|
|
3034
|
$this->set_data(pack "n", $record->{key}); |
66
|
|
|
|
|
|
|
# the block name is usually "\000"; calculate its length, |
67
|
|
|
|
|
|
|
# then pad it so that storing the name length (1 byte) |
68
|
|
|
|
|
|
|
# + $name + padding takes an even number of bytes |
69
|
1399
|
|
|
|
|
1179
|
my $name_length = length $name; |
70
|
1399
|
100
|
|
|
|
1826
|
my $padding = ($name_length % 2) == 0 ? "\000" : ""; |
71
|
1399
|
|
|
|
|
2807
|
$this->set_data(pack("C", $name_length) . $name . $padding); |
72
|
|
|
|
|
|
|
# initialise $data with the record dump. |
73
|
1399
|
|
|
|
|
2326
|
my $data = $record->get(); |
74
|
|
|
|
|
|
|
# the next four bytes encode the resource data size. Also in this |
75
|
|
|
|
|
|
|
# case the total size must be padded to an even number of bytes |
76
|
1399
|
|
|
|
|
1223
|
my $data_length = length $data; |
77
|
1399
|
100
|
|
|
|
2387
|
$data .= "\000" if ($data_length % 2) == 1; |
78
|
1399
|
|
|
|
|
2944
|
$this->set_data(pack("N", $data_length)); |
79
|
1399
|
|
|
|
|
2267
|
$this->set_data($data); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
########################################################### |
83
|
|
|
|
|
|
|
# This auxiliary routine dumps all IPTC datasets in the # |
84
|
|
|
|
|
|
|
# @$record subdirectory, referring to the $r_number IPTC # |
85
|
|
|
|
|
|
|
# record, and concatenates them into a string, which is # |
86
|
|
|
|
|
|
|
# returned at the end. See parse_IPTC_dataset for details.# |
87
|
|
|
|
|
|
|
########################################################### |
88
|
|
|
|
|
|
|
sub dump_IPTC_datasets { |
89
|
98
|
|
|
98
|
0
|
121
|
my ($r_number, $record) = @_; |
90
|
|
|
|
|
|
|
# prepare the scalar to be returned at the end |
91
|
98
|
|
|
|
|
158
|
my $block = ""; |
92
|
|
|
|
|
|
|
# Each IPTC record is a sequence of variable length data sets. Each |
93
|
|
|
|
|
|
|
# dataset begins with a "tag marker" (its value is fixed) followed |
94
|
|
|
|
|
|
|
# by the "record number" (given by $r_number), followed by the |
95
|
|
|
|
|
|
|
# dataset number, length and data. |
96
|
98
|
|
|
|
|
150
|
for (@$record) { |
97
|
910
|
|
|
|
|
1570
|
my ($dnumber, $type, $count, $dataref) = $_->get(); |
98
|
910
|
|
|
|
|
1689
|
$block .= pack "CCCn", ($APP13_IPTC_TAGMARKER, $r_number, |
99
|
|
|
|
|
|
|
$dnumber, length $$dataref); |
100
|
910
|
|
|
|
|
1122
|
$block .= $$dataref; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
# return the encoded datasets |
103
|
98
|
|
|
|
|
207
|
return $block; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# successful load |
107
|
|
|
|
|
|
|
1; |