284 lines
10 KiB
Perl
284 lines
10 KiB
Perl
#------------------------------------------------------------------------------
|
|
# File: Protobuf.pm
|
|
#
|
|
# Description: Decode protocol buffer data
|
|
#
|
|
# Revisions: 2024-12-04 - P. Harvey Created
|
|
#
|
|
# Notes: Tag definitions for Protobuf tags support additional 'signed',
|
|
# 'unsigned' and 'int64s' formats for varInt (type 0) values,
|
|
# and 'rational' for byte (type 2) values
|
|
#
|
|
# References: 1) https://protobuf.dev/programming-guides/encoding/
|
|
#------------------------------------------------------------------------------
|
|
|
|
package Image::ExifTool::Protobuf;
|
|
|
|
use strict;
|
|
use vars qw($VERSION);
|
|
use Image::ExifTool qw(:DataAccess :Utils);
|
|
|
|
$VERSION = '1.03';
|
|
|
|
sub ProcessProtobuf($$$;$);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read bytes from dirInfo object
|
|
# Inputs: 0) dirInfo ref (with DataPt and Pos set), 1) number of bytes
|
|
# Returns: binary data or undef on error
|
|
sub GetBytes($$)
|
|
{
|
|
my ($dirInfo, $n) = @_;
|
|
my $dataPt = $$dirInfo{DataPt};
|
|
my $pos = $$dirInfo{Pos};
|
|
return undef if $pos + $n > length $$dataPt;
|
|
$$dirInfo{Pos} += $n;
|
|
return substr($$dataPt, $pos, $n);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read variable-length integer
|
|
# Inputs: 0) dirInfo ref
|
|
# Returns: integer value
|
|
sub VarInt($)
|
|
{
|
|
my $dirInfo = shift;
|
|
my $val = 0;
|
|
my $shift = 0;
|
|
for (;;) {
|
|
my $buff = GetBytes($dirInfo, 1);
|
|
defined $buff or return undef;
|
|
$val += (ord($buff) & 0x7f) << $shift;
|
|
last unless ord($buff) & 0x80;
|
|
$shift += 7;
|
|
}
|
|
return $val;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read protobuf record
|
|
# Inputs: 0) dirInfo ref
|
|
# Returns: 0) record payload (plus tag id and format type in list context)
|
|
# Notes: Updates dirInfo Pos to start of next record
|
|
sub ReadRecord($)
|
|
{
|
|
my $dirInfo = shift;
|
|
my $val = VarInt($dirInfo);
|
|
return undef unless defined $val;
|
|
my $id = $val >> 3;
|
|
my $type = $val & 0x07;
|
|
my $buff;
|
|
|
|
if ($type == 0) { # varInt
|
|
$buff = VarInt($dirInfo);
|
|
} elsif ($type == 1) { # 64-bit number
|
|
$buff = GetBytes($dirInfo, 8);
|
|
} elsif ($type == 2) { # string, bytes or protobuf
|
|
my $len = VarInt($dirInfo);
|
|
if ($len) {
|
|
$buff = GetBytes($dirInfo, $len);
|
|
} else {
|
|
$buff = '';
|
|
}
|
|
} elsif ($type == 3) { # (deprecated start group)
|
|
$buff = '';
|
|
} elsif ($type == 4) { # (deprecated end group)
|
|
$buff = '';
|
|
} elsif ($type == 5) { # 32-bit number
|
|
$buff = GetBytes($dirInfo, 4);
|
|
}
|
|
return wantarray ? ($buff, $id, $type) : $buff;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check to see if this could be a protobuf object
|
|
# Inputs: 0) data reference
|
|
# Retursn: true if this looks like a protobuf
|
|
sub IsProtobuf($)
|
|
{
|
|
my $pt = shift;
|
|
my $dirInfo = { DataPt => $pt, Pos => 0 };
|
|
for (;;) {
|
|
return 0 unless defined ReadRecord($dirInfo);
|
|
return 1 if $$dirInfo{Pos} == length $$pt;
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process protobuf data (eg. DJI djmd timed data from Action4 videos) (ref 1)
|
|
# Inputs: 0) ExifTool ref, 1) dirInfo ref with DataPt, DataPos, DirName and Base,
|
|
# 2) tag table ptr, 3) prefix of parent protobuf ID's
|
|
# Returns: true on success
|
|
sub ProcessProtobuf($$$;$)
|
|
{
|
|
my ($et, $dirInfo, $tagTbl, $prefix) = @_;
|
|
my $dataPt = $$dirInfo{DataPt};
|
|
my $dirName = $$dirInfo{DirName};
|
|
my $dirStart = $$dirInfo{DirStart} || 0;
|
|
my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
|
|
my $dirEnd = $dirStart + $dirLen;
|
|
my $dataPos = ($$dirInfo{Base} || 0) + ($$dirInfo{DataPos} || 0);
|
|
my $unknown = $et->Options('Unknown') || $et->Options('Verbose');
|
|
|
|
$$dirInfo{Pos} = $$dirInfo{DirStart} || 0; # initialize buffer Pos
|
|
$et->VerboseDir('Protobuf', undef, $dirLen);
|
|
|
|
unless ($prefix) {
|
|
$prefix = '';
|
|
$$et{ProtoPrefix}{$dirName} = '' unless defined $$et{ProtoPrefix}{$dirName};
|
|
SetByteOrder('II');
|
|
}
|
|
# loop through protobuf records
|
|
for (;;) {
|
|
my $pos = $$dirInfo{Pos};
|
|
last if $pos >= $dirEnd;
|
|
my ($buff, $id, $type) = ReadRecord($dirInfo);
|
|
defined $buff or $et->Warn('Protobuf format error'), last;
|
|
if ($type == 2 and $buff =~ /\.proto$/) {
|
|
# save protocol name separately for directory type
|
|
$$et{ProtoPrefix}{$dirName} = substr($buff, 0, -6) . '_';
|
|
$et->HandleTag($tagTbl, Protocol => $buff);
|
|
}
|
|
my $tag = "$$et{ProtoPrefix}{$dirName}$prefix$id";
|
|
my $tagInfo = $$tagTbl{$tag};
|
|
if ($tagInfo) {
|
|
next if $type != 2 and $$tagInfo{Unknown} and not $unknown;
|
|
} else {
|
|
next unless $type == 2 or $unknown;
|
|
$tagInfo = AddTagToTable($tagTbl, $tag, { Unknown => 1 });
|
|
}
|
|
# set IsProtobuf flag (only for Unknown tags) if necessary
|
|
if ($type == 2 and $$tagInfo{Unknown}) {
|
|
if ($$tagInfo{IsProtobuf}) {
|
|
$$tagInfo{IsProtobuf} = 0 unless IsProtobuf(\$buff);
|
|
} elsif (not defined $$tagInfo{IsProtobuf} and $buff =~ /[^\x20-\x7e]/ and
|
|
IsProtobuf(\$buff))
|
|
{
|
|
$$tagInfo{IsProtobuf} = 1;
|
|
}
|
|
next unless $$tagInfo{IsProtobuf} or $unknown;
|
|
}
|
|
# format binary payload into a useful value
|
|
my $val;
|
|
if ($$tagInfo{Format}) {
|
|
if ($type == 0) {
|
|
$val = $buff;
|
|
if ($$tagInfo{Format} eq 'signed') {
|
|
$val = ($val & 1) ? -($val >> 1)-1 : ($val >> 1);
|
|
} elsif ($$tagInfo{Format} eq 'int64s' and $val > 0xffffffff) {
|
|
# hack for DJI drones which store 64-bit signed integers improperly
|
|
# (just toss upper 32 bits which should be all 1's anyway)
|
|
$val = ($val & 0xffffffff) - 4294967296;
|
|
}
|
|
} elsif ($type == 2 and $$tagInfo{Format} eq 'rational') {
|
|
my $dir = { DataPt => \$buff, Pos => 0 };
|
|
my $num = VarInt($dir);
|
|
my $den = VarInt($dir);
|
|
$val = (defined $num and $den) ? $num/$den : 'err';
|
|
} else {
|
|
$val = ReadValue(\$buff, 0, $$tagInfo{Format}, undef, length($buff));
|
|
}
|
|
} elsif ($type == 0) { # varInt
|
|
$val = $buff;
|
|
my $hex = sprintf('%x', $val);
|
|
if (length($hex) == 16 and $hex =~ /^ffffffff/) {
|
|
my $s64 = hex(substr($hex, 8)) - 4294967296;
|
|
$val .= " (0x$hex, int64s $s64)";
|
|
} else {
|
|
my $signed = ($val & 1) ? -($val >> 1)-1 : ($val >> 1);
|
|
$val .= " (0x$hex, signed $signed)";
|
|
}
|
|
} elsif ($type == 1) { # 64-bit number
|
|
$val = '0x' . unpack('H*', $buff) . ' (double ' . GetDouble(\$buff,0) . ')';
|
|
} elsif ($type == 2) { # string, bytes or protobuf
|
|
if ($$tagInfo{SubDirectory}) {
|
|
# (fall through to process known SubDirectory)
|
|
} elsif ($$tagInfo{IsProtobuf}) {
|
|
# process Unknown protobuf directories
|
|
$et->VPrint(1, "$$et{INDENT}Protobuf $tag (" . length($buff) . " bytes) -->\n");
|
|
my $addr = $dataPos + $$dirInfo{Pos} - length($buff);
|
|
$et->VerboseDump(\$buff, Addr => $addr, Prefix => $$et{INDENT});
|
|
my %subdir = ( DataPt => \$buff, DataPos => $addr, DirName => $dirName );
|
|
$$et{INDENT} .= '| ';
|
|
ProcessProtobuf($et, \%subdir, $tagTbl, "$prefix$id-");
|
|
$$et{INDENT} = substr($$et{INDENT}, 0, -2);
|
|
next;
|
|
} else {
|
|
# check for rational value (2 varInt values)
|
|
my $rat;
|
|
my %dir = ( DataPt => \$buff, Pos => 0 );
|
|
my $num = VarInt(\%dir);
|
|
if (defined $num) {
|
|
my $denom = VarInt(\%dir);
|
|
$rat = " (rational $num/$denom)" if $denom and $dir{Pos} == length($buff);
|
|
}
|
|
if ($buff !~ /[^\x20-\x7e]/) {
|
|
$val = $buff; # assume this is an ASCII string
|
|
} elsif (length($buff) % 4) {
|
|
$val = '0x' . unpack('H*', $buff);
|
|
} else {
|
|
my $n = length($buff) / 4;
|
|
# (do this instead of '(H8)*' because older Perl version didn't support this)
|
|
$val = '0x' . join(' ', unpack("(H8)$n", $buff)); # (group in 4-byte blocks)
|
|
}
|
|
$val .= $rat if $rat;
|
|
}
|
|
} elsif ($type == 5) { # 32-bit number
|
|
$val = '0x' . unpack('H*', $buff) . ' (int32u ' . Get32u(\$buff, 0);
|
|
$val .= ', int32s ' . Get32s(\$buff, 0) if ord(substr($buff,3,1)) & 0x80;
|
|
$val .= ', float ' . GetFloat(\$buff, 0) . ')';
|
|
} else {
|
|
$val = $buff;
|
|
}
|
|
# get length of data in the record
|
|
my $start = $type == 0 ? $pos + 1 : $$dirInfo{Pos} - length $buff;
|
|
$et->HandleTag($tagTbl, $tag, $val,
|
|
DataPt => $dataPt,
|
|
DataPos=> $dataPos,
|
|
Start => $start,
|
|
Size => $$dirInfo{Pos} - $start,
|
|
Extra => ", type=$type",
|
|
Format => $$tagInfo{Format},
|
|
);
|
|
}
|
|
# warn if we didn't finish exactly at the end of the buffer
|
|
$et->Warn('Truncated protobuf data') unless $prefix or $$dirInfo{Pos} == $dirEnd;
|
|
return 1;
|
|
}
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Image::ExifTool::Protobuf - Decode protocol buffer information
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
This module is loaded automatically by Image::ExifTool when required.
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module contains definitions required by Image::ExifTool to decode
|
|
information in protocol buffer (protobuf) format.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Copyright 2003-2025, Phil Harvey (philharvey66 at gmail.com)
|
|
|
|
This library is free software; you can redistribute it and/or modify it
|
|
under the same terms as Perl itself.
|
|
|
|
=head1 REFERENCES
|
|
|
|
=over 4
|
|
|
|
=item L<https://protobuf.dev/programming-guides/encoding/>
|
|
|
|
=back
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Image::ExifTool(3pm)|Image::ExifTool>
|
|
|
|
=cut
|