libimage-exiftool-perl 10.80-1 / usr / share / perl5 / Image / ExifTool / Fixup.pm

#------------------------------------------------------------------------------
# File:         Fixup.pm
#
# Description:  Utility to handle pointer fixups
#
# Revisions:    01/19/2005 - P. Harvey Created
#               04/11/2005 - P. Harvey Allow fixups to be tagged with a marker,
#                            and add new marker-related routines
#               06/21/2006 - P. Harvey Patch to work with negative offsets
#               07/07/2006 - P. Harvey Added support for 16-bit pointers
#               02/19/2013 - P. Harvey Added IsEmpty()
#
# Data Members:
#
#   Start     - Position in data where a zero pointer points to.
#   Shift     - Amount to shift offsets (relative to Start).
#   Fixups    - List of Fixup object references to to shift relative to this Fixup.
#   Pointers  - Hash of references to fixup pointer arrays, keyed by ByteOrder
#               string (with "2" added if pointer is 16-bit [default is 32-bit],
#               plus "_$marker" suffix if tagged with a marker name).
#
# Procedure:
#
#            1. Create a Fixup object for each data block containing pointers
#            2. Call AddFixup with the offset of each pointer in the block
#               - pointer is assumed int32u with the current byte order
#               - may also be called with a fixup reference for contained blocks
#            3. Add the necessary pointer offset to $$fixup{Shift}
#            4. Add data size to $$fixup{Start} if data is added before the block
#               - automatically also shifts pointers by this amount
#            5. Call ApplyFixup to apply the fixup to all pointers
#               - resets Shift and Start to 0 after applying fixup
#------------------------------------------------------------------------------

package Image::ExifTool::Fixup;

use strict;
use Image::ExifTool qw(GetByteOrder SetByteOrder Get32u Get32s Set32u
                       Get16u Get16s Set16u);
use vars qw($VERSION);

$VERSION = '1.05';

sub AddFixup($$;$$);
sub ApplyFixup($$);
sub Dump($;$);

#------------------------------------------------------------------------------
# New - create new Fixup object
# Inputs: 0) reference to Fixup object or Fixup class name
sub new
{
    local $_;
    my $that = shift;
    my $class = ref($that) || $that || 'Image::ExifTool::Fixup';
    my $self = bless {}, $class;

    # initialize required members
    $self->{Start} = 0;
    $self->{Shift} = 0;

    return $self;
}

#------------------------------------------------------------------------------
# Clone this object
# Inputs: 0) reference to Fixup object or Fixup class name
# Returns: reference to new Fixup object
sub Clone($)
{
    my $self = shift;
    my $clone = new Image::ExifTool::Fixup;
    $clone->{Start} = $self->{Start};
    $clone->{Shift} = $self->{Shift};
    my $phash = $self->{Pointers};
    if ($phash) {
        $clone->{Pointers} = { };
        my $byteOrder;
        foreach $byteOrder (keys %$phash) {
            my @pointers = @{$phash->{$byteOrder}};
            $clone->{Pointers}->{$byteOrder} = \@pointers;
        }
    }
    if ($self->{Fixups}) {
        $clone->{Fixups} = [ ];
        my $subFixup;
        foreach $subFixup (@{$self->{Fixups}}) {
            push @{$clone->{Fixups}}, $subFixup->Clone();
        }
    }
    return $clone;
}

#------------------------------------------------------------------------------
# Add fixup pointer or another fixup object below this one
# Inputs: 0) Fixup object reference
#         1) Scalar for pointer offset, or reference to Fixup object
#         2) Optional marker name for the pointer
#         3) Optional pointer format ('int16u' or 'int32u', defaults to 'int32u')
# Notes: Byte ordering must be set properly for the pointer being added (must keep
# track of the byte order of each offset since MakerNotes may have different byte order!)
sub AddFixup($$;$$)
{
    my ($self, $pointer, $marker, $format) = @_;
    if (ref $pointer) {
        $self->{Fixups} or $self->{Fixups} = [ ];
        push @{$self->{Fixups}}, $pointer;
    } else {
        my $byteOrder = GetByteOrder();
        if (defined $format) {
            if ($format eq 'int16u') {
                $byteOrder .= '2';
            } elsif ($format ne 'int32u') {
                warn "Bad Fixup pointer format $format\n";
            }
        }
        $byteOrder .= "_$marker" if defined $marker;
        my $phash = $self->{Pointers};
        $phash or $phash = $self->{Pointers} = { };
        $phash->{$byteOrder} or $phash->{$byteOrder} = [ ];
        push @{$phash->{$byteOrder}}, $pointer;
    }
}

#------------------------------------------------------------------------------
# fix up pointer offsets
# Inputs: 0) Fixup object reference, 1) data reference
# Outputs: Collapses fixup hierarchy into linear lists of fixup pointers
sub ApplyFixup($$)
{
    my ($self, $dataPt) = @_;

    my $start = $self->{Start};
    my $shift = $self->{Shift} + $start;   # make shift relative to start
    my $phash = $self->{Pointers};

    # fix up pointers in this fixup
    if ($phash and ($start or $shift)) {
        my $saveOrder = GetByteOrder(); # save original byte ordering
        my ($byteOrder, $ptr);
        foreach $byteOrder (keys %$phash) {
            SetByteOrder(substr($byteOrder,0,2));
            # apply the fixup offset shift (must get as signed integer
            # to avoid overflow in case it was negative before)
            my ($get, $set) = ($byteOrder =~ /^(II2|MM2)/) ?
                              (\&Get16s, \&Set16u) : (\&Get32s, \&Set32u);
            foreach $ptr (@{$phash->{$byteOrder}}) {
                $ptr += $start;         # update pointer to new start location
                next unless $shift;
                &$set(&$get($dataPt, $ptr) + $shift, $dataPt, $ptr);
            }
        }
        SetByteOrder($saveOrder);       # restore original byte ordering
    }
    # recurse into contained fixups
    if ($self->{Fixups}) {
        # create our pointer hash if it doesn't exist
        $phash or $phash = $self->{Pointers} = { };
        # loop through all contained fixups
        my $subFixup;
        foreach $subFixup (@{$self->{Fixups}}) {
            # adjust the subfixup start and shift
            $subFixup->{Start} += $start;
            $subFixup->{Shift} += $shift - $start;
            # recursively apply contained fixups
            ApplyFixup($subFixup, $dataPt);
            my $shash = $subFixup->{Pointers} or next;
            # add all pointers to our collapsed lists
            my $byteOrder;
            foreach $byteOrder (keys %$shash) {
                $phash->{$byteOrder} or $phash->{$byteOrder} = [ ];
                push @{$phash->{$byteOrder}}, @{$shash->{$byteOrder}};
                delete $shash->{$byteOrder};
            }
            delete $subFixup->{Pointers};
        }
        delete $self->{Fixups};    # remove our contained fixups
    }
    # reset our Start/Shift for the collapsed fixup
    $self->{Start} = $self->{Shift} = 0;
}

#------------------------------------------------------------------------------
# Is this Fixup empty?
# Inputs: 0) Fixup object ref
# Returns: True if there are no offsets to fix
sub IsEmpty($)
{
    my $self = shift;
    my $phash = $self->{Pointers};
    if ($phash) {
        my $key;
        foreach $key (keys %$phash) {
            next unless ref $$phash{$key} eq 'ARRAY';
            return 0 if @{$$phash{$key}};
        }
    }
    return 1;
}

#------------------------------------------------------------------------------
# Does specified marker exist?
# Inputs: 0) Fixup object reference, 1) marker name
# Returns: True if fixup contains specified marker name
sub HasMarker($$)
{
    my ($self, $marker) = @_;
    my $phash = $self->{Pointers};
    return 0 unless $phash;
    return 1 if grep /_$marker$/, keys %$phash;
    return 0 unless $self->{Fixups};
    my $subFixup;
    foreach $subFixup (@{$self->{Fixups}}) {
        return 1 if $subFixup->HasMarker($marker);
    }
    return 0;
}

#------------------------------------------------------------------------------
# Set all marker pointers to specified value
# Inputs: 0) Fixup object reference, 1) data reference
#         2) marker name, 3) pointer value, 4) offset to start of data
sub SetMarkerPointers($$$$;$)
{
    my ($self, $dataPt, $marker, $value, $startOffset) = @_;
    my $start = $self->{Start} + ($startOffset || 0);
    my $phash = $self->{Pointers};

    if ($phash) {
        my $saveOrder = GetByteOrder(); # save original byte ordering
        my ($byteOrder, $ptr);
        foreach $byteOrder (keys %$phash) {
            next unless $byteOrder =~ /^(II|MM)(2?)_$marker$/;
            SetByteOrder($1);
            my $set = $2 ? \&Set16u : \&Set32u;
            foreach $ptr (@{$phash->{$byteOrder}}) {
                &$set($value, $dataPt, $ptr + $start);
            }
        }
        SetByteOrder($saveOrder);       # restore original byte ordering
    }
    if ($self->{Fixups}) {
        my $subFixup;
        foreach $subFixup (@{$self->{Fixups}}) {
            $subFixup->SetMarkerPointers($dataPt, $marker, $value, $start);
        }
    }
}

#------------------------------------------------------------------------------
# Get pointer values for specified marker
# Inputs: 0) Fixup object reference, 1) data reference,
#         2) marker name, 3) offset to start of data
# Returns: List of marker pointers in list context, or first marker pointer otherwise
sub GetMarkerPointers($$$;$)
{
    my ($self, $dataPt, $marker, $startOffset) = @_;
    my $start = $self->{Start} + ($startOffset || 0);
    my $phash = $self->{Pointers};
    my @pointers;

    if ($phash) {
        my $saveOrder = GetByteOrder();
        my ($byteOrder, $ptr);
        foreach $byteOrder (grep /_$marker$/, keys %$phash) {
            SetByteOrder(substr($byteOrder,0,2));
            my $get = ($byteOrder =~ /^(II2|MM2)/) ? \&Get16u : \&Get32u;
            foreach $ptr (@{$phash->{$byteOrder}}) {
                push @pointers, &$get($dataPt, $ptr + $start);
            }
        }
        SetByteOrder($saveOrder);       # restore original byte ordering
    }
    if ($self->{Fixups}) {
        my $subFixup;
        foreach $subFixup (@{$self->{Fixups}}) {
            push @pointers, $subFixup->GetMarkerPointers($dataPt, $marker, $start);
        }
    }
    return @pointers if wantarray;
    return $pointers[0];
}

#------------------------------------------------------------------------------
# Dump fixup to console for debugging
# Inputs: 0) Fixup object reference, 1) optional initial indent string
sub Dump($;$)
{
    my ($self, $indent) = @_;
    $indent or $indent = '';
    printf "${indent}Fixup start=0x%x shift=0x%x\n", $self->{Start}, $self->{Shift};
    my $phash = $self->{Pointers};
    if ($phash) {
        my $byteOrder;
        foreach $byteOrder (sort keys %$phash) {
            print "$indent  $byteOrder: ", join(' ',@{$phash->{$byteOrder}}),"\n";
        }
    }
    if ($self->{Fixups}) {
        my $subFixup;
        foreach $subFixup (@{$self->{Fixups}}) {
            Dump($subFixup, $indent . '  ');
        }
    }
}


1; # end

__END__

=head1 NAME

Image::ExifTool::Fixup - Utility to handle pointer fixups

=head1 SYNOPSIS

    use Image::ExifTool::Fixup;

    $fixup = new Image::ExifTool::Fixup;

    # add a new fixup to a pointer at the specified offset in data
    $fixup->AddFixup($offset);

    # add a new Fixup object to the tree
    $fixup->AddFixup($subFixup);

    $fixup->{Start} += $shift1;   # shift pointer offsets and values

    $fixup->{Shift} += $shift2;   # shift pointer values only

    # recursively apply fixups to the specified data
    $fixup->ApplyFixups(\$data);

    $fixup->Dump();               # dump debugging information

    $fixup->IsEmpty();            # return true if no offsets to fix

=head1 DESCRIPTION

This module contains the code to keep track of pointers in memory and to
shift these pointers as required.  It is used by ExifTool to maintain the
pointers in image file directories (IFD's).

=head1 NOTES

Keeps track of pointers with different byte ordering, and relies on
Image::ExifTool::GetByteOrder() to determine the current byte ordering
when adding new pointers to a fixup.

Maintains a hierarchical list of fixups so that the whole hierarchy can
be shifted by a simple shift at the base.  Hierarchy is collapsed to a
linear list when ApplyFixups() is called.

=head1 AUTHOR

Copyright 2003-2018, Phil Harvey (phil at owl.phy.queensu.ca)

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

L<Image::ExifTool(3pm)|Image::ExifTool>

=cut