File Coverage

blib/lib/Finnigan/Decoder.pm

Criterion	Covered	Total	%
statement	128	227	56.3
branch	32	94	34.0
condition	3	12	25.0
subroutine	11	16	68.7
pod	11	11	100.0
total	185	360	51.3

package Finnigan::Decoder;

use 5.010000;
use strict;
use warnings FATAL => qw( all );
our $VERSION = 0.0206;

use Encode qw//;
use Carp qw/confess/;

sub read {
  my ($class, $stream, $fields, $any_arg) = @_;
  my $self = {size => 0};

  bless $self, $class;
  $self->decode($stream, $fields, $any_arg);
  return $self;
}

sub iterate_object {
  my ($self, $stream, $count, $name, $class, $any_arg) = @_;

  my $addr = tell $stream;

  my $current_element_number = keys(%{$self->{data}}) + 1;

  confess qq(key "$name" already exists) if $self->{data}->{$name};

  my $size = 0;
  foreach my $i ( 1 .. $count ) {
    my $value = $class->decode($stream, $any_arg);
    $size += $value->{size};
    push @{$self->{data}->{$name}->{value}}, $value;
  }

  $self->{data}->{$name}->{seq} = $current_element_number;
  $self->{data}->{$name}->{addr} = $addr,
  $self->{data}->{$name}->{size} = $size,
  $self->{data}->{$name}->{type} = "$class\[\]",

  $self->{size} += $size;
  $self->{current_element_number}++;

  return $self;
}

sub iterate_scalar {
  my ($self, $stream, $count, $name, $desc) = @_;
  my ($template, $type) = @$desc;

  my $addr = my $current_addr = tell $stream;

  my $current_element_number = keys(%{$self->{data}}) + 1;

  confess qq(key "$name" already exists) if $self->{data}->{$name};

  my $size = 0;
  my ($rec, $nbytes);
  my ($i, $bytes_to_read);

  if ( $template eq 'varstr' ) {
    if ( $type eq 'PascalStringWin32' ) {
      for ($i = 1; $i <= $count; $i++) {
        # read the prefix counter into $nchars
        my $bytes_to_read = 4;
        $nbytes = CORE::read $stream, $rec, $bytes_to_read;
        $nbytes == $bytes_to_read
          or die "could not read all $bytes_to_read bytes of the prefix counter in $name at $current_addr";
        my $nchars = unpack "V", $rec;

        # read the 2-byte characters
        $bytes_to_read = 2*$nchars;
        $nbytes = CORE::read $stream, $rec, $bytes_to_read;
        $nbytes == $bytes_to_read
          or die "could not read all $nchars 2-byte characters of $name at $current_addr";
        $nbytes += 4; # total string length

        $size += $nbytes;
        $current_addr += $nbytes;

        push @{$self->{data}->{$name}->{value}}, Encode::decode('UTF-16LE', (pack "C*", unpack "U0C*", $rec));
      }
    }
    else {
      confess "unknown varstr type $type";
    }
  }
  else {
    my $template_length = length(pack($template,()));
    if ( substr($template, 0, 3) eq 'U0C' ) {
      foreach $i ( 1 .. $count ) {
        $nbytes = CORE::read $stream, $rec, $template_length;
        $nbytes == $template_length
          or die "could not read all $template_length bytes of $name at $current_addr";

        $size += $nbytes;
        $current_addr += $nbytes;

        push @{$self->{data}->{$name}->{value}}, pack ( "C*", unpack $template, $rec );
      }
    }
    else {
      foreach $i ( 1 .. $count ) {
        $nbytes = CORE::read $stream, $rec, $template_length;
        $nbytes == $template_length
          or die "could not read all $template_length bytes of $name at $current_addr";

        $size += $nbytes;
        $current_addr += $nbytes;

        push @{$self->{data}->{$name}->{value}}, unpack ( $template, $rec );
      }
    }
  }

  $self->{data}->{$name}->{seq} = $current_element_number;
  $self->{data}->{$name}->{addr} = $addr,
  $self->{data}->{$name}->{size} = $size,
  $self->{data}->{$name}->{type} = $type,

  $self->{size} += $size;
  $self->{current_element_number}++;

  return $self;
}

sub decode {
  my ($self, $stream, $fields, $any_arg) = @_;
  my ( $rec, $nbytes );

  my $current_addr = tell $stream;
  $self->{addr} ||= $current_addr; # assign the address only if called
                                   # the first time (because decoding
                                   # can be done in multiple chunks)

  my $current_element_number = keys %{$self->{data}};

  my $value;
  foreach my $i ( 0 .. @$fields/2 - 1 ) {
    my $name = $fields->[2*$i];
    unless ( $fields->[2*$i+1] ) {
      # it is a spacer in the human-readable generic record
      $self->{data}->{$name} = {
            seq => $current_element_number + $i,
            addr => $current_addr,
            size => 0,
            type => 'spacer',
            value => '',
           };

      $self->{current_element_number} = $i;
      next;
    }

    my ($template, $type) = @{$fields->[2*$i+1]};

    confess qq(key "$name" already exists) if $self->{data}->{$name};

    if ( $template eq 'object' ) {
      $value = $type->decode($stream, $any_arg);
      $nbytes = $value->{size};
    }
    elsif ( $template eq 'varstr' ) {
      if ( $type eq 'PascalStringWin32' ) {
        # read the prefix counter into $nchars
        my $bytes_to_read = 4;
        $nbytes = CORE::read $stream, $rec, $bytes_to_read;
        $nbytes == $bytes_to_read
          or die "could not read all $bytes_to_read bytes of the prefix counter in $name at $current_addr";
        my $nchars = unpack "V", $rec;

        # read the 2-byte characters
        $bytes_to_read = 2*$nchars;
        $nbytes = CORE::read $stream, $rec, $bytes_to_read;
        $nbytes == $bytes_to_read
          or die "could not read all $nchars 2-byte characters of $name at $current_addr";
        $rec =~ s/\xb0/\*/; # remove the degree sign
        #print(STDERR (ord > 127 ? sprintf("<%02X>", ord) : $_)) for(split //, $rec); print STDERR "\n";
        $value = Encode::decode('UTF-16LE', (pack "C*", unpack "U0C*", $rec));
        $nbytes += 4;
      }
      else {
        confess "unknown varstr type $type";
      }
    }
    elsif ( $template eq 'string' ) {
      if ( substr($type, 0, 6) eq 'ASCIIZ' ) {
        (undef, my $bytes_to_read) = split ":", $type;
        $nbytes = CORE::read $stream, $rec, $bytes_to_read;
        $nbytes == $bytes_to_read
          or die "could not read all $bytes_to_read bytes of the string in $name at $current_addr";
        $value = unpack "Z*", $rec;
      }
      elsif ( substr($type, 0, 9) eq 'UTF-16-LE' ) {
        (undef, my $bytes_to_read) = split ":", $type;
        $nbytes = CORE::read $stream, $rec, $bytes_to_read;
        $nbytes == $bytes_to_read
          or die "could not read all $bytes_to_read bytes of the string in $name at $current_addr";
        ($value) = split /\0/, Encode::decode('UTF-16LE', (pack "C*", unpack "U0C*", $rec)); # decode and truncate at 0
      }
      elsif ( substr($type, 0, 9) eq 'UTF-16-BE' ) {
        confess "UTF-16-BE not implemented";
      }
      else {
        confess "unknown string type";
      }
    }
    elsif ( $template eq 'windows_time' ) {
      my $bytes_to_read = 8;
      $nbytes = CORE::read $stream, $rec, $bytes_to_read;
      $nbytes == $bytes_to_read
        or die "could not read all $bytes_to_read bytes of $name at $current_addr";
      my ($w1, $w2) = unpack "VV", $rec;
      $value = scalar gmtime (($w2 * 4294967296 + $w1) / 10000000 - 11644473600); # Windows timestamp is 100s of ns since Jan 1 1601
    }
    else {
      my $bytes_to_read = length(pack($template,()));
      $nbytes = CORE::read $stream, $rec, $bytes_to_read;
      $nbytes == $bytes_to_read
        or die "could not read all $bytes_to_read bytes of $name at $current_addr";

      if ( substr($template, 0, 3) eq 'U0C' ) {
        $value = pack "C*", unpack $template, $rec;
      }
      else {
        $value = unpack $template, $rec;
      }
    }

    $self->{data}->{$name} = {
            seq => $current_element_number + $i,
            addr => $current_addr,
            size => $nbytes,
            type => $type,
            value => $value,
           };

    $current_addr = tell $stream;
    $self->{size} += $nbytes;
    $self->{current_element_number} = $i;
  }

  return $self;
}

sub size {
  shift->{size};
}

sub data {
  shift->{data};
}

sub addr {
  shift->{addr};
}

sub item {
  my ($self, $key) = @_;
  $self->{data}->{$key};
}

sub values {
  my ($self) = @_;
  return {map { $_ => $self->{data}->{$_}->{value} } keys %{$self->{data}}};
}

sub dump {
  my ( $self, %arg ) = @_;

  my $addr = $self->{addr};

  $arg{header}++ unless exists $arg{header}; # print the header by default

  my @keys = sort {
    $self->data->{$a}->{seq} <=> $self->data->{$b}->{seq}
  } keys %{$self->{data}};

  if ( $arg{filter} ) {
    my %filter = map {$_ => 1} @{$arg{filter}};
    @keys = grep {$filter{$_}} @keys;
  }

  if ($arg{style} and $arg{style} eq 'html') {
    say ""; " if $arg{header}; " " " " " " " 




286




0




  
  0
  




 





 





 





 



     say "   offset size type key value 




287




0





 





 





 





 





 



     foreach my $key ( @keys ) { 




288




0




  
  0
  




 





 





 





 



       my $offset = $arg{relative} ? $self->item($key)->{addr} - $addr :  $self->item($key)->{addr}; 




289




0





 





 





 





 





 



       my $value = $self->item($key)->{value}; 




290




0





 





 





 





 





 



       my $type = $self->item($key)->{type}; 




291




0





 





 





 





 





 



       $type =~ s/^Finnigan:://; 




292




0




  
  0
  




 





 





 





 



       if ( ref $value eq 'ARRAY' ) { 




293




0





 





 





 





 





 



         $value = join ", ", map {"$_"} @$value; 




 




0





 





 





 





 





 



   




294




 





 





 





 





 





 



       } 




295




0




  
  0
  




 





 





 





 



       if ( $type eq 'RawBytes' ) { 




296




0





 





 





 





 





 



         my $len = length($value); 




297




0





 





 





 





 





 



         my @list = unpack('C*', substr($value, 0, 16)); 




298




0





 





 





 





 





 



         $_ = sprintf "%2.2x", $_ for @list; 




299




0





 





 





 





 





 



         $value = join(" ", @list); 




300




0




  
  0
  




 





 





 





 



         $value .= " ..." if $len > 16; 




301




 





 





 





 





 





 



       } 




302




0





 





 





 





 





 



       say "  




303




 





 





 





 





 





 



         . " " . $offset . "




304




 





 





 





 





 





 



           . " " . $self->item($key)->{size} . "




305




 





 





 





 





 





 



             . " " . $type . "




306




 





 





 





 





 





 



               . " " . $key . "




307




 





 





 





 





 





 



                 . " $value




308




 





 





 





 





 





 



                   . " 




309




 





 





 





 





 





 



                     ; 




310




 





 





 





 





 





 



     } 




311




0





 





 





 





 





 



     say "";
    say "
    foreach my $key ( @keys ) {
      my $offset = $arg{relative} ? $self->item($key)->{addr} - $addr :  $self->item($key)->{addr};
      my $value = $self->item($key)->{value};
      my $type = $self->item($key)->{type};
      $type =~ s/^Finnigan:://;
      if ( ref $value eq 'ARRAY' ) {
        $value = join ", ", map {"$_"} @$value;
      }
      if ( $type eq 'RawBytes' ) {
        my $len = length($value);
        my @list = unpack('C*', substr($value, 0, 16));
        $_ = sprintf "%2.2x", $_ for @list;
        $value = join(" ", @list);
        $value .= " ..." if $len > 16;
      }
      say "
        . "
          . "
            . "
              . "
                . "
                  . "
                    ;
    }
    say "
  }
  elsif ($arg{style} and $arg{style} eq 'wiki') {
    say "|| " . join(" || ", qw/offset size type key value/) . " ||" if $arg{header};
    foreach my $key ( @keys ) {
      my $offset = $arg{relative} ? $self->item($key)->{addr} - $addr :  $self->item($key)->{addr};
      my $value = $self->item($key)->{value};
      my $type = $self->item($key)->{type};
      $type =~ s/^Finnigan:://;
      $type =~ s/\[\]/\`[]\`/;
      if ($self->item($key)->{type} eq 'UTF16LE'
          and substr($value, 0, 2) eq "\x00\x00") {
        $value =~ s/\x00/00 /g;
        if (length($value) > 20) {
          $value = substr($value, 0, 30) . "...";
        }
      }
      if ( ref $value eq 'ARRAY' ) {
        $value = join ", ", map {"$_"} @$value;
      }
      if ( $type eq 'RawBytes' ) {
        my $len = length($value);
        my @list = unpack('C*', substr($value, 0, 16));
        $_ = sprintf "%2.2x", $_ for @list;
        $value = join(" ", @list);
        $value .= " ..." if $len > 16;
      }
      say "|| " . join(" || ",
           $offset,
           $self->item($key)->{size},
           $type,
           "\`$key\`",
           "\`$value\`"
          ). " ||";
    }
  }
  else {
    foreach my $key ( @keys ) {
      my $offset = $arg{relative} ? $self->item($key)->{addr} - $addr :  $self->item($key)->{addr};
      my $value = $self->item($key)->{value};
      my $type = $self->item($key)->{type};
      $type =~ s/^Finnigan:://;
      if ( ref $value eq 'ARRAY' ) {
        $value = join ", ", map {"$_"} @$value;
      }
      if ( $type eq 'RawBytes' ) {
        my $len = length($value);
        my @list = unpack('C*', substr($value, 0, 16));
        $_ = sprintf "%2.2x", $_ for @list;
        $value = join(" ", @list);
        $value .= " ..." if $len > 16;
      }
      say join("\t",
         $offset,
         $self->item($key)->{size},
         $type,
         $key,
         "$value"
        );
    }
  }
}

sub purge_unused_data {
  my $self = shift;
  delete $self->{current_element_number};
  delete $self->{addr};
  delete $self->{size};
  foreach my $key (keys %{$self->{data}}) {
    if ( substr($key, 0, 4) eq 'unkn' ) {
      delete $self->{data}->{$key};
    }
    else {
      delete $self->{data}->{$key}->{type};
      delete $self->{data}->{$key}->{addr};
      delete $self->{data}->{$key}->{seq};
      delete $self->{data}->{$key}->{size};
    }
  }
  return $self;
}

1;
__END__