exiftool_vendored 13.04.0 → 13.08.0

data/bin/lib/Image/ExifTool/Photoshop.pm

@@ -28,11 +28,12 @@ use strict;
 use vars qw($VERSION $AUTOLOAD $iptcDigestInfo %printFlags);
 use Image::ExifTool qw(:DataAccess :Utils);
 
-$VERSION = '1.71';
+$VERSION = '1.72';
 
 sub ProcessPhotoshop($$$);
 sub WritePhotoshop($$$);
 sub ProcessLayers($$$);
+sub ProcessChannelOptions($$$);
 
 # PrintFlags bit definitions (ref forum13785)
 %printFlags = (
@@ -322,7 +323,13 @@ my %unicodeString = (
     0x0432 => { Unknown => 1, Name => 'MeasurementScale' }, #7
     0x0433 => { Unknown => 1, Name => 'TimelineInfo' }, #7
     0x0434 => { Unknown => 1, Name => 'SheetDisclosure' }, #7
-    0x0435 => { Unknown => 1, Name => 'ChannelOptions' }, #7/forum16762
+    0x0435 => {
+        Name => 'ChannelOptions', #7/forum16762
+        SubDirectory => {
+            TagTable => 'Image::ExifTool::Photoshop::ChannelOptions',
+            Start => 4,
+        },
+    },
     0x0436 => { Unknown => 1, Name => 'OnionSkins' }, #7
     0x0438 => { Unknown => 1, Name => 'CountInfo' }, #7
     0x043a => { Unknown => 1, Name => 'PrintInfo2' }, #7
@@ -350,6 +357,40 @@ my %unicodeString = (
     0x2710 => { Unknown => 1, Name => 'PrintFlagsInfo' },
 );
 
+# Photoshop channel options (ref forum16762)
+%Image::ExifTool::Photoshop::ChannelOptions = (
+    PROCESS_PROC => \&ProcessChannelOptions,
+    VARS => { IS_BINARY => 1 },
+    GROUPS => { 2 => 'Image' },
+    0 => {
+        Name => 'ChannelColorSpace',
+        Format => 'int16u',
+        PrintConv => {
+            0 => 'RGB',
+            1 => 'HSB',
+            2 => 'CMYK',
+            7 => 'Lab',
+            8 => 'Grayscale',
+        },
+    },
+    2 => {
+        Name => 'ChannelColorData',
+        Format => 'int16u[4]',
+    },
+    11 => {
+        Name => 'ChannelOpacity',
+        PrintConv => '"$val%"',
+    },
+    12 => {
+        Name => 'ChannelColorIndicates',
+        PrintConv => {
+            0 => 'Selected Areas',
+            1 => 'Masked Areas',
+            2 => 'Spot Color',
+        },
+    },
+);
+
 # Photoshop JPEG quality record (ref 2)
 %Image::ExifTool::Photoshop::JPEG_Quality = (
     PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
@@ -755,6 +796,25 @@ sub ProcessLayersAndMask($$$)
     return $raf->Seek($end, 0) ? 1 : 0;
 }
 
+#------------------------------------------------------------------------------
+# Process Photoshop channel options (ref forum16762)
+# Inputs: 0) ExifTool ref, 1) DirInfo ref, 2) tag table ref
+# Returns: 1 on success
+sub ProcessChannelOptions($$$)
+{
+    my ($et, $dirInfo, $tagTablePtr) = @_;
+    my $end = $$dirInfo{DirStart}  + $$dirInfo{DirLen};
+    $$dirInfo{DirLen} = 13;
+    my $i;
+    for ($i=0; $$dirInfo{DirStart} + 13 <= $end; ++$i) {
+        $$et{SET_GROUP1} = "Channel$i";
+        $et->ProcessBinaryData($dirInfo, $tagTablePtr);
+        $$dirInfo{DirStart} += 13;
+    }
+    delete $$et{SET_GROUP1};
+    return 1;
+}
+
 #------------------------------------------------------------------------------
 # Process Photoshop layers (beginning with layer count)
 # Inputs: 0) ExifTool ref, 1) DirInfo ref, 2) tag table ref
@@ -1050,7 +1110,7 @@ sub ProcessPhotoshop($$$)
     if ($$et{VALUE}{IPTCDigest} and $$et{VALUE}{CurrentIPTCDigest} and
         $$et{VALUE}{IPTCDigest} ne $$et{VALUE}{CurrentIPTCDigest})
     {
-        $et->WarnOnce('IPTCDigest is not current. XMP may be out of sync');
+        $et->Warn('IPTCDigest is not current. XMP may be out of sync');
     }
     delete $$et{LOW_PRIORITY_DIR}{'*'};
     return $success;

data/bin/lib/Image/ExifTool/Protobuf.pm

@@ -0,0 +1,242 @@
+#------------------------------------------------------------------------------
+# File:         Protobuf.pm
+#
+# Description:  Decode protocol buffer data
+#
+# Revisions:    2024-12-04 - P. Harvey Created
+#
+# Notes:        Tag definitions for Protobuf tags support additional 'signed'
+#               and 'unsigned' formats for varInt (type 0) 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.00';
+
+sub ProcessProtobuf($$$;$);
+
+#------------------------------------------------------------------------------
+# Read bytes from dirInfo object
+# Inputs: 0) dirInfo ref, 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, 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 $unknown = $et->Options('Unknown') || $et->Options('Verbose');
+
+    $$dirInfo{Pos} = $$dirInfo{DirStart} || 0; # initialize buffer Pos
+
+    unless ($prefix) {
+        $prefix = '';
+        $$et{ProtocolName}{$dirName} = '*' unless defined $$et{ProtocolName}{$dirName};
+        SetByteOrder('II');
+    }
+    # loop through protobuf records
+    for (;;) {
+        my $pos = $$dirInfo{Pos};
+        last if $pos >= length $$dataPt;
+        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{ProtocolName}{$dirName} = substr($buff, 0, -6);
+            $et->HandleTag($tagTbl, Protocol => $buff);
+        }
+        my $tag = "$$et{ProtocolName}{$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;
+                $val = ($val & 1) ? -($val >> 1)-1 : ($val >> 1) if $$tagInfo{Format} eq 'signed';
+            } else {
+                $val = ReadValue(\$buff, 0, $$tagInfo{Format}, undef, length($buff));
+            }
+        } elsif ($type == 0) {
+            $val = $buff;
+            my $signed = ($val & 1) ? -($val >> 1)-1 : ($val >> 1);
+            $val .= sprintf(" (0x%x, signed $signed)", $val);
+        } elsif ($type == 1) {
+            $val = '0x' . unpack('H*', $buff) . ' (double ' . GetDouble(\$buff,0) . ')';
+        } elsif ($type == 2) {
+            if ($$tagInfo{IsProtobuf}) {
+                $et->VPrint(1, "+ Protobuf $tag (" . length($buff) . " bytes)\n");
+                my $addr = $$dirInfo{Base} + $$dirInfo{Pos} - length($buff);
+                $et->VerboseDump(\$buff, Addr => $addr);
+                my %subdir = ( DataPt => \$buff, Base => $addr, DirName => $dirName );
+                ProcessProtobuf($et, \%subdir, $tagTbl, "$prefix$id-");
+                next;
+            } elsif ($buff !~ /[^\x20-\x7e]/) {
+                $val = $buff;   # assume this is an ASCII string
+            } elsif (length($buff) % 4) {
+                $val = '0x' . unpack('H*', $buff);
+            } else {
+                $val = '0x' . join(' ', unpack('(H8)*', $buff)); # (group in 4-byte blocks)
+            }
+        } elsif ($type == 5) {
+            $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=> $$dirInfo{Base},
+            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} == length $$dataPt;
+    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-2024, 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

data/bin/lib/Image/ExifTool/QuickTime.pm

@@ -69,8 +69,9 @@ sub Process_gps0($$$);
 sub Process_gsen($$$);
 sub Process_gdat($$$);
 sub Process_nbmt($$$);
+sub ProcessLigoGPS($$$;$);
+sub ProcessLigoJSON($$$);
 sub ProcessKenwood($$$);
-sub ProcessLIGO_JSON($$$);
 sub ProcessRIFFTrailer($$$);
 sub ProcessTTAD($$$);
 sub ProcessNMEA($$$);
@@ -255,7 +256,7 @@ my %timeInfo = (
         my $offset = (66 * 365 + 17) * 24 * 3600;
         return $val - $offset if $val >= $offset or $$self{OPTIONS}{QuickTimeUTC};
         if ($val and not $$self{IsWriting}) {
-            $self->WarnOnce('Patched incorrect time zero for QuickTime date/time tag',1);
+            $self->Warn('Patched incorrect time zero for QuickTime date/time tag',1);
         }
         return $val;
     },
@@ -584,6 +585,14 @@ my %userDefined = (
             Condition => '$$valPt =~ /^\0[\0-\x04]..[a-zA-Z ]{4}/s',
             SubDirectory => { TagTable => 'Image::ExifTool::QuickTime::SkipInfo' },
         },
+        {
+            Name => 'LigoGPSInfo',
+            Condition => '$$valPt =~ /^LIGOGPSINFO\0/',
+            SubDirectory => { 
+                TagTable => 'Image::ExifTool::QuickTime::Stream',
+                ProcessProc => \&ProcessLigoGPS,
+            },
+        },
         { Name => 'Skip', Unknown => 1, Binary => 1 },
     ],
     wide => { Unknown => 1, Binary => 1 },
@@ -677,7 +686,7 @@ my %userDefined = (
             Condition => '$$valPt=~/^\xef\xe1\x58\x9a\xbb\x77\x49\xef\x80\x95\x27\x75\x9e\xb1\xdc\x6f/',
             Notes => 'raw 360Fly sensor data without ExtractEmbedded option',
             RawConv => q{
-                $self->WarnOnce('Use the ExtractEmbedded option to decode timed SensorData',3);
+                $self->Warn('Use the ExtractEmbedded option to decode timed SensorData',3);
                 return \$val;
             },
         },
@@ -762,11 +771,11 @@ my %userDefined = (
             ProcessProc => \&ProcessKenwood,
         },
     },{
-        Name => 'LIGO_JSON',
+        Name => 'LigoJSON',
         Condition => '$$valPt =~ /^LIGOGPSINFO \{/',
         SubDirectory => {
             TagTable => 'Image::ExifTool::QuickTime::Stream',
-            ProcessProc => \&ProcessLIGO_JSON,
+            ProcessProc => \&ProcessLigoJSON,
         },
     },{
         Name => 'FLIRData',
@@ -1303,7 +1312,7 @@ my %userDefined = (
             Condition => '$$valPt=~/^\x9b\x63\x0f\x8d\x63\x74\x40\xec\x82\x04\xbc\x5f\xf5\x09\x17\x28/',
             Notes => 'Garmin GPS sensor data',
             RawConv => q{
-                $self->WarnOnce('Use the ExtractEmbedded option to decode timed Garmin GPS',3);
+                $self->Warn('Use the ExtractEmbedded option to decode timed Garmin GPS',3);
                 return \$val;
             },
         },
@@ -1407,7 +1416,7 @@ my %userDefined = (
             if ($val >= $offset or $$self{OPTIONS}{QuickTimeUTC}) {
                 $val -= $offset;
             } elsif ($val and not $$self{IsWriting}) {
-                $self->WarnOnce('Patched incorrect time zero for QuickTime date/time tag',1);
+                $self->Warn('Patched incorrect time zero for QuickTime date/time tag',1);
             }
             return $$self{CreateDate} = $val;
         },
@@ -2557,7 +2566,7 @@ my %userDefined = (
     TTID => { Name => 'TomTomID', ValueConv => 'unpack("x4H*",$val)' },
     TTVI => { Name => 'TomTomVI', Format => 'int32u', Unknown => 1 }, # seen: "0 1 61 508 508"
     # TTVD seen: "normal 720p 60fps 60fps 16/9 wide 1x"
-    TTVD => { Name => 'TomTomVD', ValueConv => 'my @a = ($val =~ /[\x20-\x7f]+/g); "@a"', List => 1 },
+    TTVD => { Name => 'TomTomVD', ValueConv => 'my @a = ($val =~ /[\x20-\x7e]+/g); "@a"', List => 1 },
 );
 
 # User-specific media data atoms (ref 11)
@@ -9031,11 +9040,11 @@ sub HandleItemInfo($)
             }
             $warn = "Can't currently decode protected $type metadata" if $$item{ProtectionIndex};
             $warn = "Can't currently extract $type with construction method $$item{ConstructionMethod}" if $$item{ConstructionMethod};
-            $et->WarnOnce($warn) if $warn and $name;
+            $et->Warn($warn) if $warn and $name;
             $warn = 'Not this file' if $$item{DataReferenceIndex}; # (can only extract from "this file")
             unless (($$item{Extents} and @{$$item{Extents}}) or $warn) {
                 $warn = "No Extents for $type item";
-                $et->WarnOnce($warn) if $name;
+                $et->Warn($warn) if $name;
             }
             if ($warn) {
                 $et->VPrint(0, "$$et{INDENT}    [not extracted]  ($warn)\n") if $verbose > 2;
@@ -9099,7 +9108,7 @@ sub HandleItemInfo($)
                     $et->VerboseDump(\$buff);
                 } else {
                     $warn = "Error inflating $name metadata";
-                    $et->WarnOnce($warn);
+                    $et->Warn($warn);
                     $et->VPrint(0, "$$et{INDENT}    [not extracted]  ($warn)\n") if $verbose > 2;
                     next;
                 }
@@ -9188,7 +9197,7 @@ sub HandleItemInfo($)
 sub EEWarn($)
 {
     my $et = shift;
-    $et->WarnOnce('The ExtractEmbedded option may find more tags in the media data',3);
+    $et->Warn('The ExtractEmbedded option may find more tags in the media data',3);
 }
 
 #------------------------------------------------------------------------------
@@ -9675,7 +9684,7 @@ sub ProcessMOV($$;$)
                     $warnStr = 'End of processing at large atom (LargeFileSupport not enabled)';
                     last;
                 } elsif ($et->Options('LargeFileSupport') eq '2') {
-                    $et->WarnOnce('Processing large atom (LargeFileSupport is 2)');
+                    $et->Warn('Processing large atom (LargeFileSupport is 2)');
                 }
             }
             $size = $hi * 4294967296 + $lo - 16;
@@ -9690,7 +9699,7 @@ sub ProcessMOV($$;$)
             if ($$et{ValidatePath}{$path} and not $dupTagOK{$tag} and not $dupDirOK{$dirID}) {
                 my $i = Get32u(\$tag,0);
                 my $str = $i < 255 ? "index $i" : "tag '" . PrintableTagID($tag,2) . "'";
-                $et->WarnOnce("Duplicate $str at " . join('-', @{$$et{PATH}}));
+                $et->Warn("Duplicate $str at " . join('-', @{$$et{PATH}}));
                 $$et{ValidatePath} = { } if $path eq 'MOV-moov'; # avoid warnings for all contained dups
             }
             $$et{ValidatePath}{$path} = 1;