libparse-win32registry-perl 1.0-2 / usr / share / perl5 / Parse / Win32Registry / WinNT / Value.pm

package Parse::Win32Registry::WinNT::Value;

use strict;
use warnings;

use base qw(Parse::Win32Registry::Value);

use Carp;
use Encode;
use Parse::Win32Registry::Base qw(:all);

use constant VK_HEADER_LENGTH => 0x18;
use constant OFFSET_TO_FIRST_HBIN => 0x1000;

sub new {
    my $class = shift;
    my $regfile = shift;
    my $offset = shift; # offset to vk record relative to first hbin

    croak 'Missing registry file' if !defined $regfile;
    croak 'Missing offset' if !defined $offset;

    my $fh = $regfile->get_filehandle;

    # 0x00 dword = value length (negative = allocated)
    # 0x04 word  = 'vk' signature
    # 0x06 word  = value name length
    # 0x08 dword = value data length (bit 31 set => data stored inline)
    # 0x0c dword = offset to data/inline data
    # 0x10 dword = value type
    # 0x14 word  = flags (bit 1 set => compressed name)
    # 0x16 word
    # 0x18       = value name [for value name length bytes]

    # Extracted offsets are always relative to first hbin

    sysseek($fh, $offset, 0);
    my $bytes_read = sysread($fh, my $vk_header, VK_HEADER_LENGTH);
    if ($bytes_read != VK_HEADER_LENGTH) {
        warnf('Could not read value at 0x%x', $offset);
        return;
    }

    my ($length,
        $sig,
        $name_length,
        $data_length,
        $offset_to_data,
        $type,
        $flags,
        ) = unpack('Va2vVVVv', $vk_header);

    my $allocated = 0;
    if ($length > 0x7fffffff) {
        $allocated = 1;
        $length = (0xffffffff - $length) + 1;
    }
    # allocated should be true

    if ($length < VK_HEADER_LENGTH) {
        warnf('Invalid value entry length at 0x%x', $offset);
        return;
    }

    if ($sig ne 'vk') {
        warnf('Invalid signature for value at 0x%x', $offset);
        return;
    }

    $bytes_read = sysread($fh, my $name, $name_length);
    if ($bytes_read != $name_length) {
        warnf('Could not read name for value at 0x%x', $offset);
        return;
    }

    if ($flags & 1) {
        $name = decode($Parse::Win32Registry::Base::CODEPAGE, $name);
    }
    else {
        $name = decode('UCS-2LE', $name);
    };

    # If the top bit of the data_length is set, then
    # the value is inline and stored in the offset to data field (at 0xc).
    my $data;
    my $data_inline = $data_length >> 31;
    if ($data_inline) {
        # REG_DWORDs are always inline, but I've also seen
        # REG_SZ, REG_BINARY, REG_EXPAND_SZ, and REG_NONE inline
        $data_length &= 0x7fffffff;
        if ($data_length > 4) {
            warnf("Invalid inline data length for value '%s' at 0x%x",
                $name, $offset);
            $data = undef;
        }
        else {
            # unpack inline data from header
            $data = substr($vk_header, 0xc, $data_length);
        }
    }
    else {
        if ($offset_to_data != 0 && $offset_to_data != 0xffffffff) {
            $offset_to_data += OFFSET_TO_FIRST_HBIN;
            if ($offset_to_data < ($regfile->get_length - $data_length)) {
                $data = _extract_data($fh, $offset_to_data, $data_length);
            }
            else {
                warnf("Invalid offset to data for value '%s' at 0x%x",
                    $name, $offset);
            }
        }
    }

    my $self = {};
    $self->{_regfile} = $regfile;
    $self->{_offset} = $offset;
    $self->{_length} = $length;
    $self->{_allocated} = $allocated;
    $self->{_tag} = $sig;
    $self->{_name} = $name;
    $self->{_name_length} = $name_length;
    $self->{_type} = $type;
    $self->{_data} = $data;
    $self->{_data_length} = $data_length;
    $self->{_data_inline} = $data_inline;
    $self->{_offset_to_data} = $offset_to_data;
    $self->{_flags} = $flags;
    bless $self, $class;

    return $self;
}

sub _extract_data {
    my $fh = shift;
    my $offset_to_data = shift;
    my $data_length = shift;

    if ($offset_to_data == 0 || $offset_to_data == 0xffffffff) {
        return undef;
    }

    sysseek($fh, $offset_to_data, 0);
    my $bytes_read = sysread($fh, my $data_header, 4);
    if ($bytes_read != 4) {
        warnf('Could not read data at 0x%x', $offset_to_data);
        return undef;
    }

    my ($max_data_length) = unpack('V', $data_header);

    my $data_allocated = 0;
    if ($max_data_length > 0x7fffffff) {
        $data_allocated = 1;
        $max_data_length = (0xffffffff - $max_data_length) + 1;
    }
    # data_allocated should be true

    my $data;

    if ($data_length > $max_data_length) {
        $bytes_read = sysread($fh, my $db_entry, 8);
        if ($bytes_read != 8) {
            warnf('Could not read data at 0x%x', $offset_to_data);
            return undef;
        }

        my ($sig, $num_data_blocks, $offset_to_data_block_list)
            = unpack('a2vV', $db_entry);
        if ($sig ne 'db') {
            warnf('Invalid signature for big data at 0x%x', $offset_to_data);
            return undef;
        }
        $offset_to_data_block_list += OFFSET_TO_FIRST_HBIN;

        sysseek($fh, $offset_to_data_block_list + 4, 0);
        $bytes_read = sysread($fh, my $data_block_list, $num_data_blocks * 4);
        if ($bytes_read != $num_data_blocks * 4) {
            warnf('Could not read data block list at 0x%x',
                $offset_to_data_block_list);
            return undef;
        }

        $data = "";
        my @offsets = map { OFFSET_TO_FIRST_HBIN + $_ }
            unpack("V$num_data_blocks", $data_block_list);
        foreach my $offset (@offsets) {
            sysseek($fh, $offset, 0);
            $bytes_read = sysread($fh, my $block_header, 4);
            if ($bytes_read != 4) {
                warnf('Could not read data block at 0x%x', $offset);
                return undef;
            }
            my ($block_length) = unpack('V', $block_header);
            if ($block_length > 0x7fffffff) {
                $block_length = (0xffffffff - $block_length) + 1;
            }
            $bytes_read = sysread($fh, my $block_data, $block_length - 8);
            if ($bytes_read != $block_length - 8) {
                warnf('Could not read data block at 0x%x', $offset);
                return undef;
            }
            $data .= $block_data;
        }
        if (length($data) < $data_length) {
            warnf("Insufficient data blocks for data at 0x%x", $offset_to_data);
            return undef;
        }
        $data = substr($data, 0, $data_length);
        return $data;
    }
    else {
        $bytes_read = sysread($fh, $data, $data_length);
        if ($bytes_read != $data_length) {
            warnf("Could not read data at 0x%x", $offset_to_data);
            return undef;
        }
    }
    return $data;
}

sub get_data {
    my $self = shift;

    my $type = $self->get_type;

    my $data = $self->{_data};
    return if !defined $data;

    # apply decoding to appropriate data types
    if ($type == REG_DWORD) {
        if (length($data) == 4) {
            $data = unpack('V', $data);
        }
        else {
            # incorrect length for dword data
            $data = undef;
        }
    }
    elsif ($type == REG_DWORD_BIG_ENDIAN) {
        if (length($data) == 4) {
            $data = unpack('N', $data);
        }
        else {
            # incorrect length for dword data
            $data = undef;
        }
    }
    elsif ($type == REG_SZ || $type == REG_EXPAND_SZ) {
        $data = decode('UCS-2LE', $data);
        # snip off any terminating null
        chop $data if substr($data, -1, 1) eq "\0";
    }
    elsif ($type == REG_MULTI_SZ) {
        $data = decode('UCS-2LE', $data);
        # snip off any terminating nulls
        chop $data if substr($data, -1, 1) eq "\0";
        chop $data if substr($data, -1, 1) eq "\0";
        my @multi_sz = split("\0", $data, -1);
        # make sure there is at least one empty string
        @multi_sz = ('') if @multi_sz == 0;
        return wantarray ? @multi_sz : join($", @multi_sz);
    }

    return $data;
}

sub as_regedit_export {
    my $self = shift;
    my $version = shift || 5;

    my $name = $self->get_name;
    my $export = $name eq '' ? '@=' : '"' . $name . '"=';

    my $type = $self->get_type;

    # XXX
#    if (!defined $self->{_data}) {
#        $name = $name eq '' ? '@' : qq{"$name"};
#        return qq{; $name=(invalid data)\n};
#    }

    if ($type == REG_SZ) {
        $export .= '"' . $self->get_data . '"';
        $export .= "\n";
    }
    elsif ($type == REG_BINARY) {
        $export .= "hex:";
        $export .= format_octets($self->{_data}, length($export));
    }
    elsif ($type == REG_DWORD) {
        my $data = $self->get_data;
        $export .= defined($data)
            ? sprintf("dword:%08x", $data)
            : "dword:";
        $export .= "\n";
    }
    elsif ($type == REG_EXPAND_SZ || $type == REG_MULTI_SZ) {
        my $data = $version == 4
                 ? encode("ascii", $self->{_data}) # unicode->ascii
                 : $self->{_data}; # raw data
        $export .= sprintf("hex(%x):", $type);
        $export .= format_octets($data, length($export));
    }
    else {
        $export .= sprintf("hex(%x):", $type);
        $export .= format_octets($self->{_data}, length($export));
    }
    return $export;
}

sub parse_info {
    my $self = shift;

    my $info = sprintf '0x%x vk len=0x%x alloc=%d "%s" type=%d',
        $self->{_offset},
        $self->{_length},
        $self->{_allocated},
        $self->{_name},
        $self->{_type};
    if ($self->{_data_inline}) {
        $info .= sprintf ' data=inline,len=0x%x',
            $self->{_data_length};
    }
    else {
        $info .= sprintf ' data=0x%x,len=0x%x',
            $self->{_offset_to_data},
            $self->{_data_length};
    }
    return $info;
}

1;