/usr/share/perl5/Image/MetaData/JPEG/dumpers/app13.pl is in libimage-metadata-jpeg-perl 0.153-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 | ###########################################################
# A Perl package for showing/modifying JPEG (meta)data. #
# Copyright (C) 2004,2005,2006 Stefano Bettelli #
# See the COPYING and LICENSE files for license terms. #
###########################################################
use Image::MetaData::JPEG::data::Tables qw(:TagsAPP13);
no integer;
use strict;
use warnings;
###########################################################
# This routine dumps the Adobe identifier and then enters #
# a loop on the resource data block dumper, till the end. #
# TODO: implement dumping of multiple blocks!!!! #
###########################################################
sub dump_app13 {
my ($this) = @_;
# get a reference to the segment record list
my $records = $this->{records};
# the segment always starts with an Adobe identifier
$this->die('Identifier not found') unless
my $id = $this->search_record_value('Identifier');
$this->set_data($id);
# version 2.5 (old) is followed by eight undocumented bytes
# (maybe resolution info): output them if present and valid
my $rec = $this->search_record('Resolution');
$this->die('Header problem') unless (defined $rec) eq ($id =~ /2\.5/);
$this->set_data($rec->get_value()) if $rec;
# for each possible IPTC record number (remember that there can be
# multiple IPTC subdirs, referring to different IPTC records), dump
# the corresponding IPTC block, if present; the easiest solution is
# to create a fake Record, which is then dumped as usual
for my $r_number (1..9) {
next unless my $record
= $this->search_record("${APP13_IPTC_DIRNAME}_${r_number}");
my $content = $record->get_value();
my $block = dump_IPTC_datasets($r_number, $content);
my $fake_record = new Image::MetaData::JPEG::Record
($APP13_PHOTOSHOP_IPTC, $UNDEF, \ $block, length $block);
$fake_record->{extra} = $record->{extra};
$this->dump_resource_data_block($fake_record); }
# do the same on all non-IPTC subdirs (remember that there can be
# multiple non-IPTC subdirs, with type '8BIM', '8BPS', 'PHUT', ...)
for my $type (@$APP13_PHOTOSHOP_TYPE) {
next unless my $record
= $this->search_record("${APP13_PHOTOSHOP_DIRNAME}_${type}");
$this->dump_resource_data_block($_,$type) for @{$record->get_value()};}
# return without errors
return undef;
}
###########################################################
# TODO: implement dumping of multiple blocks!!!! #
###########################################################
sub dump_resource_data_block {
my ($this, $record, $type) = @_;
# try to extract an optional name from the extra field
my $name = $record->{extra} ? $record->{extra} : '';
# provide a default type if $type is null
$type = $$APP13_PHOTOSHOP_TYPE[0] unless $type;
# dump the resource data block type
$this->set_data($type);
# dump the block identifier, which is the numeric tag
# of the record (as a 2-byte unsigned integer).
$this->set_data(pack "n", $record->{key});
# the block name is usually "\000"; calculate its length,
# then pad it so that storing the name length (1 byte)
# + $name + padding takes an even number of bytes
my $name_length = length $name;
my $padding = ($name_length % 2) == 0 ? "\000" : "";
$this->set_data(pack("C", $name_length) . $name . $padding);
# initialise $data with the record dump.
my $data = $record->get();
# the next four bytes encode the resource data size. Also in this
# case the total size must be padded to an even number of bytes
my $data_length = length $data;
$data .= "\000" if ($data_length % 2) == 1;
$this->set_data(pack("N", $data_length));
$this->set_data($data);
}
###########################################################
# This auxiliary routine dumps all IPTC datasets in the #
# @$record subdirectory, referring to the $r_number IPTC #
# record, and concatenates them into a string, which is #
# returned at the end. See parse_IPTC_dataset for details.#
###########################################################
sub dump_IPTC_datasets {
my ($r_number, $record) = @_;
# prepare the scalar to be returned at the end
my $block = "";
# Each IPTC record is a sequence of variable length data sets. Each
# dataset begins with a "tag marker" (its value is fixed) followed
# by the "record number" (given by $r_number), followed by the
# dataset number, length and data.
for (@$record) {
my ($dnumber, $type, $count, $dataref) = $_->get();
$block .= pack "CCCn", ($APP13_IPTC_TAGMARKER, $r_number,
$dnumber, length $$dataref);
$block .= $$dataref;
}
# return the encoded datasets
return $block;
}
# successful load
1;
|