line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2
|
|
|
|
|
|
|
# File: WritePhotoshop.pl |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# Description: Write Photoshop IRB meta information |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# Revisions: 12/17/2004 - P. Harvey Created |
7
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
package Image::ExifTool::Photoshop; |
10
|
|
|
|
|
|
|
|
11
|
15
|
|
|
15
|
|
97
|
use strict; |
|
15
|
|
|
|
|
35
|
|
|
15
|
|
|
|
|
17558
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
14
|
|
|
|
|
|
|
# Strip resource name from value prepare resource name for writing into IRB |
15
|
|
|
|
|
|
|
# Inputs: 0) tagInfo ref, 1) resource name (padded pascal string), 2) new value ref |
16
|
|
|
|
|
|
|
# Returns: none (updates name and value if necessary) |
17
|
|
|
|
|
|
|
sub SetResourceName($$$) |
18
|
|
|
|
|
|
|
{ |
19
|
66
|
|
|
66
|
0
|
173
|
my ($tagInfo, $name, $valPt) = @_; |
20
|
66
|
|
|
|
|
127
|
my $setName = $$tagInfo{SetResourceName}; |
21
|
66
|
50
|
|
|
|
214
|
if (defined $setName) { |
22
|
|
|
|
|
|
|
# extract resource name from value |
23
|
0
|
0
|
|
|
|
0
|
if ($$valPt =~ m{.*/#(.{0,255})#/$}s) { |
|
|
0
|
|
|
|
|
|
24
|
0
|
|
|
|
|
0
|
$name = $1; |
25
|
|
|
|
|
|
|
# strip name from value |
26
|
0
|
|
|
|
|
0
|
$$valPt = substr($$valPt, 0, -4 - length($name)); |
27
|
|
|
|
|
|
|
} elsif ($setName eq '1') { |
28
|
0
|
|
|
|
|
0
|
return; # use old name |
29
|
|
|
|
|
|
|
} else { |
30
|
0
|
|
|
|
|
0
|
$name = $setName; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
# convert to padded pascal string |
33
|
0
|
|
|
|
|
0
|
$name = chr(length $name) . $name; |
34
|
0
|
0
|
|
|
|
0
|
$name .= "\0" if length($name) & 0x01; |
35
|
0
|
|
|
|
|
0
|
$_[1] = $name; # return new name |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
40
|
|
|
|
|
|
|
# Write Photoshop IRB resource |
41
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) source dirInfo reference, |
42
|
|
|
|
|
|
|
# 2) tag table reference |
43
|
|
|
|
|
|
|
# Returns: IRB resource data (may be empty if no Photoshop data) |
44
|
|
|
|
|
|
|
# Notes: Increments ExifTool CHANGED flag for each tag changed |
45
|
|
|
|
|
|
|
sub WritePhotoshop($$$) |
46
|
|
|
|
|
|
|
{ |
47
|
75
|
|
|
75
|
0
|
225
|
my ($et, $dirInfo, $tagTablePtr) = @_; |
48
|
75
|
100
|
|
|
|
317
|
$et or return 1; # allow dummy access to autoload this package |
49
|
30
|
|
|
|
|
86
|
my $dataPt = $$dirInfo{DataPt}; |
50
|
30
|
100
|
|
|
|
95
|
unless ($dataPt) { |
51
|
19
|
|
|
|
|
49
|
my $emptyData = ''; |
52
|
19
|
|
|
|
|
43
|
$dataPt = \$emptyData; |
53
|
|
|
|
|
|
|
} |
54
|
30
|
|
100
|
|
|
153
|
my $start = $$dirInfo{DirStart} || 0; |
55
|
30
|
|
66
|
|
|
167
|
my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $start); |
56
|
30
|
|
|
|
|
72
|
my $dirEnd = $start + $dirLen; |
57
|
30
|
|
|
|
|
69
|
my $newData = ''; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# make a hash of new tag info, keyed on tagID |
60
|
30
|
|
|
|
|
160
|
my $newTags = $et->GetNewTagInfoHash($tagTablePtr); |
61
|
|
|
|
|
|
|
|
62
|
30
|
|
|
|
|
128
|
my ($addDirs, $editDirs) = $et->GetAddDirHash($tagTablePtr); |
63
|
|
|
|
|
|
|
|
64
|
30
|
|
|
|
|
121
|
SetByteOrder('MM'); # Photoshop is always big-endian |
65
|
|
|
|
|
|
|
# |
66
|
|
|
|
|
|
|
# rewrite existing tags in the old directory, deleting ones as necessary |
67
|
|
|
|
|
|
|
# (the Photoshop directory entries aren't in any particular order) |
68
|
|
|
|
|
|
|
# |
69
|
|
|
|
|
|
|
# Format: 0) Type, 4 bytes - '8BIM' (or the rare 'PHUT', 'DCSR', 'AgHg' or 'MeSa') |
70
|
|
|
|
|
|
|
# 1) TagID,2 bytes |
71
|
|
|
|
|
|
|
# 2) Name, pascal string padded to even no. bytes |
72
|
|
|
|
|
|
|
# 3) Size, 4 bytes - N |
73
|
|
|
|
|
|
|
# 4) Data, N bytes |
74
|
30
|
|
|
|
|
84
|
my ($pos, $value, $size, $tagInfo, $tagID); |
75
|
30
|
|
|
|
|
146
|
for ($pos=$start; $pos+8<$dirEnd; $pos+=$size) { |
76
|
|
|
|
|
|
|
# each entry must be on same even byte boundary as directory start |
77
|
90
|
100
|
|
|
|
193
|
++$pos if ($pos ^ $start) & 0x01; |
78
|
90
|
|
|
|
|
168
|
my $type = substr($$dataPt, $pos, 4); |
79
|
90
|
50
|
|
|
|
362
|
if ($type !~ /^(8BIM|PHUT|DCSR|AgHg|MeSa)$/) { |
80
|
0
|
|
|
|
|
0
|
$et->Error("Bad Photoshop IRB resource"); |
81
|
0
|
|
|
|
|
0
|
undef $newData; |
82
|
0
|
|
|
|
|
0
|
last; |
83
|
|
|
|
|
|
|
} |
84
|
90
|
|
|
|
|
216
|
$tagID = Get16u($dataPt, $pos + 4); |
85
|
|
|
|
|
|
|
# get resource block name (pascal string padded to an even # of bytes) |
86
|
90
|
|
|
|
|
213
|
my $namelen = 1 + Get8u($dataPt, $pos + 6); |
87
|
90
|
50
|
|
|
|
184
|
++$namelen if $namelen & 0x01; |
88
|
90
|
50
|
|
|
|
179
|
if ($pos + $namelen + 10 > $dirEnd) { |
89
|
0
|
|
|
|
|
0
|
$et->Error("Bad APP13 resource block"); |
90
|
0
|
|
|
|
|
0
|
undef $newData; |
91
|
0
|
|
|
|
|
0
|
last; |
92
|
|
|
|
|
|
|
} |
93
|
90
|
|
|
|
|
142
|
my $name = substr($$dataPt, $pos + 6, $namelen); |
94
|
90
|
|
|
|
|
188
|
$size = Get32u($dataPt, $pos + 6 + $namelen); |
95
|
90
|
|
|
|
|
139
|
$pos += $namelen + 10; |
96
|
90
|
50
|
|
|
|
168
|
if ($size + $pos > $dirEnd) { |
97
|
0
|
|
|
|
|
0
|
$et->Error("Bad APP13 resource data size $size"); |
98
|
0
|
|
|
|
|
0
|
undef $newData; |
99
|
0
|
|
|
|
|
0
|
last; |
100
|
|
|
|
|
|
|
} |
101
|
90
|
100
|
66
|
|
|
224
|
if ($$newTags{$tagID} and $type eq '8BIM') { |
102
|
3
|
|
|
|
|
7
|
$tagInfo = $$newTags{$tagID}; |
103
|
3
|
|
|
|
|
6
|
delete $$newTags{$tagID}; |
104
|
3
|
|
|
|
|
8
|
my $nvHash = $et->GetNewValueHash($tagInfo); |
105
|
|
|
|
|
|
|
# check to see if we are overwriting this tag |
106
|
3
|
|
|
|
|
7
|
$value = substr($$dataPt, $pos, $size); |
107
|
3
|
|
|
|
|
8
|
my $isOverwriting = $et->IsOverwriting($nvHash, $value); |
108
|
|
|
|
|
|
|
# handle special 'new' and 'old' values for IPTCDigest |
109
|
3
|
50
|
33
|
|
|
8
|
if (not $isOverwriting and $tagInfo eq $iptcDigestInfo) { |
110
|
0
|
0
|
|
|
|
0
|
if (grep /^new$/, @{$$nvHash{DelValue}}) { |
|
0
|
|
|
|
|
0
|
|
111
|
|
|
|
|
|
|
$isOverwriting = 1 if $$et{NewIPTCDigest} and |
112
|
0
|
0
|
0
|
|
|
0
|
$$et{NewIPTCDigest} eq $value; |
113
|
|
|
|
|
|
|
} |
114
|
0
|
0
|
|
|
|
0
|
if (grep /^old$/, @{$$nvHash{DelValue}}) { |
|
0
|
|
|
|
|
0
|
|
115
|
|
|
|
|
|
|
$isOverwriting = 1 if $$et{OldIPTCDigest} and |
116
|
0
|
0
|
0
|
|
|
0
|
$$et{OldIPTCDigest} eq $value; |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
} |
119
|
3
|
50
|
|
|
|
7
|
if ($isOverwriting) { |
120
|
3
|
|
|
|
|
11
|
$et->VerboseValue("- Photoshop:$$tagInfo{Name}", $value); |
121
|
|
|
|
|
|
|
# handle IPTCDigest specially because we want to write it last |
122
|
|
|
|
|
|
|
# so the new IPTC digest will be known |
123
|
3
|
50
|
|
|
|
8
|
if ($tagInfo eq $iptcDigestInfo) { |
124
|
0
|
|
|
|
|
0
|
$$newTags{$tagID} = $tagInfo; # add later |
125
|
0
|
|
|
|
|
0
|
$value = undef; |
126
|
|
|
|
|
|
|
} else { |
127
|
3
|
|
|
|
|
6
|
$value = $et->GetNewValue($nvHash); |
128
|
|
|
|
|
|
|
} |
129
|
3
|
|
|
|
|
5
|
++$$et{CHANGED}; |
130
|
3
|
50
|
|
|
|
7
|
next unless defined $value; # next if tag is being deleted |
131
|
|
|
|
|
|
|
# set resource name if necessary |
132
|
3
|
|
|
|
|
8
|
SetResourceName($tagInfo, $name, \$value); |
133
|
3
|
|
|
|
|
10
|
$et->VerboseValue("+ Photoshop:$$tagInfo{Name}", $value); |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} else { |
136
|
87
|
50
|
|
|
|
166
|
if ($type eq '8BIM') { |
137
|
87
|
|
|
|
|
154
|
$tagInfo = $$editDirs{$tagID}; |
138
|
87
|
100
|
|
|
|
146
|
unless ($tagInfo) { |
139
|
|
|
|
|
|
|
# process subdirectory anyway if writable (except EXIF to avoid recursion) |
140
|
|
|
|
|
|
|
# --> this allows IPTC to be processed if found here in TIFF images |
141
|
|
|
|
|
|
|
# (note that I have seen a case of XMP in PSD-EXIFInfo-IFD0, and the EXIF |
142
|
|
|
|
|
|
|
# exclusion means that this won't be written unless an EXIF tag is |
143
|
|
|
|
|
|
|
# specifically edited, see forum10768 -- maybe this should be changed |
144
|
|
|
|
|
|
|
# if it happens again) |
145
|
76
|
|
|
|
|
181
|
my $tmpInfo = $et->GetTagInfo($tagTablePtr, $tagID); |
146
|
76
|
100
|
100
|
|
|
299
|
if ($tmpInfo and $$tmpInfo{SubDirectory} and |
|
|
|
66
|
|
|
|
|
147
|
|
|
|
|
|
|
$tmpInfo->{SubDirectory}->{TagTable} ne 'Image::ExifTool::Exif::Main') |
148
|
|
|
|
|
|
|
{ |
149
|
22
|
|
|
|
|
61
|
my $table = Image::ExifTool::GetTagTable($tmpInfo->{SubDirectory}->{TagTable}); |
150
|
22
|
100
|
|
|
|
79
|
$tagInfo = $tmpInfo if $$table{WRITE_PROC}; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
} |
154
|
87
|
100
|
|
|
|
146
|
if ($tagInfo) { |
155
|
29
|
100
|
|
|
|
76
|
$$addDirs{$tagID} and delete $$addDirs{$tagID}; |
156
|
|
|
|
|
|
|
my %subdirInfo = ( |
157
|
|
|
|
|
|
|
DataPt => $dataPt, |
158
|
|
|
|
|
|
|
DirStart => $pos, |
159
|
|
|
|
|
|
|
DataLen => $dirLen, |
160
|
|
|
|
|
|
|
DirLen => $size, |
161
|
|
|
|
|
|
|
Parent => $$dirInfo{DirName}, |
162
|
29
|
|
|
|
|
152
|
); |
163
|
29
|
|
|
|
|
87
|
my $subTable = Image::ExifTool::GetTagTable($tagInfo->{SubDirectory}->{TagTable}); |
164
|
29
|
|
|
|
|
71
|
my $writeProc = $tagInfo->{SubDirectory}->{WriteProc}; |
165
|
29
|
|
|
|
|
148
|
my $newValue = $et->WriteDirectory(\%subdirInfo, $subTable, $writeProc); |
166
|
29
|
100
|
|
|
|
71
|
if (defined $newValue) { |
167
|
27
|
100
|
|
|
|
75
|
next unless length $newValue; # remove subdirectory entry |
168
|
25
|
|
|
|
|
40
|
$value = $newValue; |
169
|
25
|
|
|
|
|
66
|
SetResourceName($tagInfo, $name, \$value); |
170
|
|
|
|
|
|
|
} else { |
171
|
2
|
|
|
|
|
9
|
$value = substr($$dataPt, $pos, $size); # rewrite old directory |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
} else { |
174
|
58
|
|
|
|
|
166
|
$value = substr($$dataPt, $pos, $size); |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
} |
177
|
88
|
|
|
|
|
131
|
my $newSize = length $value; |
178
|
|
|
|
|
|
|
# write this directory entry |
179
|
88
|
|
|
|
|
172
|
$newData .= $type . Set16u($tagID) . $name . Set32u($newSize) . $value; |
180
|
88
|
100
|
|
|
|
319
|
$newData .= "\0" if $newSize & 0x01; # must null pad to even byte |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
# |
183
|
|
|
|
|
|
|
# write any remaining entries we didn't find in the old directory |
184
|
|
|
|
|
|
|
# (might as well write them in numerical tag order) |
185
|
|
|
|
|
|
|
# |
186
|
30
|
|
|
|
|
154
|
my @tagsLeft = sort { $a <=> $b } keys(%$newTags), keys(%$addDirs); |
|
37
|
|
|
|
|
80
|
|
187
|
30
|
|
|
|
|
85
|
foreach $tagID (@tagsLeft) { |
188
|
42
|
|
|
|
|
78
|
my $name = "\0\0"; |
189
|
42
|
100
|
|
|
|
109
|
if ($$newTags{$tagID}) { |
190
|
21
|
|
|
|
|
35
|
$tagInfo = $$newTags{$tagID}; |
191
|
21
|
|
|
|
|
54
|
my $nvHash = $et->GetNewValueHash($tagInfo); |
192
|
21
|
|
|
|
|
49
|
$value = $et->GetNewValue($nvHash); |
193
|
|
|
|
|
|
|
# handle new IPTCDigest value specially |
194
|
21
|
100
|
66
|
|
|
70
|
if ($tagInfo eq $iptcDigestInfo and defined $value) { |
195
|
1
|
50
|
|
|
|
5
|
if ($value eq 'new') { |
|
|
0
|
|
|
|
|
|
196
|
1
|
|
|
|
|
2
|
$value = $$et{NewIPTCDigest}; |
197
|
|
|
|
|
|
|
} elsif ($value eq 'old') { |
198
|
0
|
|
|
|
|
0
|
$value = $$et{OldIPTCDigest}; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
# (we already know we want to create this tag) |
201
|
|
|
|
|
|
|
} else { |
202
|
|
|
|
|
|
|
# don't add this tag unless specified |
203
|
20
|
100
|
|
|
|
57
|
next unless $$nvHash{IsCreating}; |
204
|
|
|
|
|
|
|
} |
205
|
17
|
50
|
|
|
|
36
|
next unless defined $value; # next if tag is being deleted |
206
|
17
|
|
|
|
|
67
|
$et->VerboseValue("+ Photoshop:$$tagInfo{Name}", $value); |
207
|
17
|
|
|
|
|
37
|
++$$et{CHANGED}; |
208
|
|
|
|
|
|
|
} else { |
209
|
21
|
|
|
|
|
43
|
$tagInfo = $$addDirs{$tagID}; |
210
|
|
|
|
|
|
|
# create new directory |
211
|
|
|
|
|
|
|
my %subdirInfo = ( |
212
|
|
|
|
|
|
|
Parent => $$dirInfo{DirName}, |
213
|
21
|
|
|
|
|
78
|
); |
214
|
21
|
|
|
|
|
83
|
my $subTable = Image::ExifTool::GetTagTable($tagInfo->{SubDirectory}->{TagTable}); |
215
|
21
|
|
|
|
|
64
|
my $writeProc = $tagInfo->{SubDirectory}->{WriteProc}; |
216
|
21
|
|
|
|
|
126
|
$value = $et->WriteDirectory(\%subdirInfo, $subTable, $writeProc); |
217
|
21
|
50
|
|
|
|
103
|
next unless $value; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
# set resource name if necessary |
220
|
38
|
|
|
|
|
143
|
SetResourceName($tagInfo, $name, \$value); |
221
|
38
|
|
|
|
|
60
|
$size = length($value); |
222
|
|
|
|
|
|
|
# write the new directory entry |
223
|
38
|
|
|
|
|
117
|
$newData .= '8BIM' . Set16u($tagID) . $name . Set32u($size) . $value; |
224
|
38
|
100
|
|
|
|
126
|
$newData .= "\0" if $size & 0x01; # must null pad to even numbered byte |
225
|
38
|
|
|
|
|
80
|
++$$et{CHANGED}; |
226
|
|
|
|
|
|
|
} |
227
|
30
|
|
|
|
|
245
|
return $newData; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
1; # end |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
__END__ |