File Coverage

blib/lib/Statistics/R/IO/REXPFactory.pm

Criterion	Covered	Total	%
statement	255	279	91.4
branch	104	132	78.7
condition	15	29	51.7
subroutine	61	63	96.8
pod	27	27	100.0
total	462	530	87.1

package Statistics::R::IO::REXPFactory;
# ABSTRACT: Functions for parsing R data files
$Statistics::R::IO::REXPFactory::VERSION = '1.0002';
use 5.010;

use strict;
use warnings FATAL => 'all';

use Exporter 'import';

our @EXPORT = qw( );
our @EXPORT_OK = qw( unserialize );

our %EXPORT_TAGS = ( all => [ @EXPORT_OK ], );

use Statistics::R::IO::Parser qw( :all );
use Statistics::R::IO::ParserState;
use Statistics::R::REXP::Character;
use Statistics::R::REXP::Double;
use Statistics::R::REXP::Integer;
use Statistics::R::REXP::List;
use Statistics::R::REXP::Logical;
use Statistics::R::REXP::Raw;
use Statistics::R::REXP::Language;
use Statistics::R::REXP::Symbol;
use Statistics::R::REXP::Null;
use Statistics::R::REXP::Closure;
use Statistics::R::REXP::GlobalEnvironment;
use Statistics::R::REXP::EmptyEnvironment;
use Statistics::R::REXP::BaseEnvironment;

use Carp;

sub header {
    seq(choose(xdr(),
               bin()),
        uint32(2),         # serialization format v2
        \&any_uint32,      # creator's R version
        uint32(0x020300)   # min R version to read (2.3.0 as of 3.0.2)
    )
}


sub xdr {
    bind(string("X\n"),         # XDR header
         sub {
             endianness('>');
             mreturn shift;
         })
}


sub bin {
    bind(string("B\n"),         # "binary" header
         sub {
             endianness('<');
             mreturn shift;
         })
}


sub object_content {
    bind(&unpack_object_info,
         \&object_data)
}


sub unpack_object_info {
    bind(\&any_uint32,
         sub {
             my $object_info = shift or return;
             mreturn { is_object => $object_info & 1<<8,
                       has_attributes => $object_info & 1<<9,
                       has_tag => $object_info & 1<<10,
                       object_type => $object_info & 0xFF,
                       levels => $object_info >> 12,
                       flags => $object_info,
                     };
         })
}


sub object_data {
    my $object_info = shift;

    if ($object_info->{object_type} == 10) {
        # logical vector
        lglsxp($object_info)
    } elsif ($object_info->{object_type} == 13) {
        # integer vector
        intsxp($object_info)
    } elsif ($object_info->{object_type} == 14) {
        # numeric vector
        realsxp($object_info)
    } elsif ($object_info->{object_type} == 15) {
        # complex vector
        cplxsxp($object_info)
    } elsif ($object_info->{object_type} == 16) {
        # character vector
        strsxp($object_info)
    } elsif ($object_info->{object_type} == 24) {
        # raw vector
        rawsxp($object_info)
    } elsif ($object_info->{object_type} == 19) {
        # list (generic vector)
        vecsxp($object_info)
    } elsif ($object_info->{object_type} == 20) {
        # expression vector
        expsxp($object_info)
    } elsif ($object_info->{object_type} == 9) {
        # internal character string
        charsxp($object_info)
    } elsif ($object_info->{object_type} == 2) {
        # pairlist
        listsxp($object_info)
    } elsif ($object_info->{object_type} == 6) {
        # language object
        langsxp($object_info)
    } elsif ($object_info->{object_type} == 1) {
        # symbol
        symsxp($object_info)
    } elsif ($object_info->{object_type} == 4) {
        # environment
        envsxp($object_info)
    } elsif ($object_info->{object_type} == 3) {
        # closure
        closxp($object_info)
    } elsif ($object_info->{object_type} == 25) {
        # closure
        s4sxp($object_info)
    } elsif ($object_info->{object_type} == 0xfb) {
        # encoded R_MissingArg, i.e., empty symbol
        mreturn(Statistics::R::REXP::Symbol->new)
    } elsif ($object_info->{object_type} == 0xf1) {
        # encoded R_BaseEnv
        mreturn(Statistics::R::REXP::BaseEnvironment->new)
    } elsif ($object_info->{object_type} == 0xf2) {
        # encoded R_EmptyEnv
        mreturn(Statistics::R::REXP::EmptyEnvironment->new)
    } elsif ($object_info->{object_type} == 0xfd) {
        # encoded R_GlobalEnv
        mreturn(Statistics::R::REXP::GlobalEnvironment->new)
    } elsif ($object_info->{object_type} == 0xfe) {
        # encoded Nil
        mreturn(Statistics::R::REXP::Null->new)
    } elsif ($object_info->{object_type} == 0xff) {
        # encoded reference to a stored singleton
        refsxp($object_info)
    } else {
        error "unimplemented SEXPTYPE: " . $object_info->{object_type}
    }
}


sub listsxp {
    my $object_info = shift;
    my $sub_items = 1;          # CAR, CDR will be read separately
    if ($object_info->{has_attributes}) {
        $sub_items++;
    }
    if ($object_info->{has_tag}) {
        $sub_items++;
    }

    bind(seq(bind(count($sub_items, object_content),
                  sub {
                      my @args = @{shift or return};
                      my %value = (value => $args[-1]);
                      $value{tag} = $args[-2] if $object_info->{has_tag};
                      $value{attributes} = $args[0] if $object_info->{has_attributes};
                      mreturn { %value };
                  }),
             object_content),   # CDR
         sub {
             my ($car, $cdr) = @{shift or return};
             my @elements = ($car);
             if (ref $cdr eq ref []) {
                 push( @elements, @{$cdr})
             }
             elsif (!$cdr->is_null) {
                 push( @elements, $cdr)
             }
             mreturn [ @elements ]
         })
}


## Language expressions are pairlists, but with a certain structure:
## - the first element is the reference (name or another language
##   expression) to the function call
## - the rest of the list are the arguments of the call, with optional
##   tags to name them
sub langsxp {
    ## After the pairlist has been parsed by `listsxp`, we want to
    ## separate the tags from the elements before invoking the Language
    ## constructor, with the tags becoming the names attribute
    bind(listsxp(@_),
         sub {
             my $list = shift or return;
             my @elements;
             my @names;
             my %attributes;
             foreach my $element (@$list) {
                 my $tag = $element->{tag};
                 my $value = $element->{value};
                 push @elements, $value;
                 push @names, $tag ? $tag->name : '';

                 if (exists $element->{attributes}) {
                     my %attribute_hash = tagged_pairlist_to_attribute_hash($element->{attributes});
                     while(my ($key, $value) = each %attribute_hash) {
                         die "Duplicate attribute $key" if
                             exists $attributes{$key};
                         $attributes{$key} = $value;
                     }
                 }
             }
             my %args = (elements => [ @elements ]);
             ## if no element is tagged, then don't construct the
             ## 'names' attribute
             if (grep {exists $_->{tag}} @$list) {
                 $attributes{names} = Statistics::R::REXP::Character->new([ @names ]);
             }
             $args{attributes} = \%attributes if %attributes;

             mreturn(Statistics::R::REXP::Language->new(%args))
         })
}


sub tagged_pairlist_to_rexp_hash {
    my $list = shift;
    return unless ref $list eq ref [];

    my %rexps;
    foreach my $element (@$list) {
        croak "Tagged element has an attribute?!"
            if exists $element->{attribute};
        my $name = $element->{tag}->name;
        $rexps{$name} = $element->{value};
    }
    %rexps
}


## Attributes are recorded as a pairlist, with attribute name in the
## element's tag, and attribute value in the element itself. Pairlists
## that serialize attributes should not have their own attribute.
sub tagged_pairlist_to_attribute_hash {
    my %rexp_hash = tagged_pairlist_to_rexp_hash @_;

    my $row_names = $rexp_hash{'row.names'};
    if ($row_names && $row_names->type eq 'integer' &&
        ! defined $row_names->elements->[0]) {
        ## compact encoding when rownames are integers 1..n: the
        ## length n is in the second element, but can be negative to
        ## denote "automatic" rownames
        my $n = abs($row_names->elements->[1]);
        $rexp_hash{'row.names'} = Statistics::R::REXP::Integer->new([1..$n]);
    }

    %rexp_hash
}


## Vector lengths are encoded as signed integers. This was fine when
## the maximum allowed length was 2^31-1; long vectors were introduced
## in R 3.0 and their length is encoded in three bytes: -1, followed
## by high and low word of a 64-bit length.
sub maybe_long_length {
    bind(\&any_int32,
         sub {
             my $len = shift;
             if ($len >= 0) {
                 mreturn $len;
             } elsif ($len == -1) {
                 error 'TODO: Long vectors are not supported';
             } else {
                 error 'Negative length detected: ' . $len;
             }
         })
}


## Vectors are serialized first with a SEXP for the vector elements,
## followed by attributes stored as a tagged pairlist.
sub vector_and_attributes {
    my ($object_info, $element_parser, $rexp_class) = @_;

    my @parsers = ( with_count(maybe_long_length, $element_parser) );
    if ($object_info->{has_attributes}) {
        push @parsers, object_content
    }

    bind(seq(@parsers),
         sub {
             my @args = @{shift or return};
             my %args = (elements => (shift(@args) || []));
             if ($object_info->{has_attributes}) {
                 $args{attributes} = { tagged_pairlist_to_attribute_hash(shift @args) };
             }
             mreturn($rexp_class->new(%args))
         })
}


sub lglsxp {
    my $object_info = shift;
    vector_and_attributes($object_info,
                          bind(\&any_uint32,
                               sub {
                                   my $x = shift;
                                   mreturn ($x != 0x80000000 ?
                                            $x : undef)
                               }),
                          'Statistics::R::REXP::Logical')
}


sub intsxp {
    my $object_info = shift;
    vector_and_attributes($object_info,
                          any_int32_na,
                          'Statistics::R::REXP::Integer')
}


sub realsxp {
    my $object_info = shift;
    vector_and_attributes($object_info,
                          any_real64_na,
                          'Statistics::R::REXP::Double')
}


sub cplxsxp {
    my $object_info = shift;

    my @parsers = ( with_count(maybe_long_length, count(2, any_real64_na)) );
    if ($object_info->{has_attributes}) {
        push @parsers, object_content
    }

    bind(seq(@parsers),
         sub {
             my @args = @{shift or return};
             my @elements = @{shift(@args) || []};
             my @cplx;
             foreach my $element (@elements) {
                 my ($re, $im) = @{$element};
                 if (defined($re) && defined($im)) {
                     push(@cplx, Math::Complex::cplx($re, $im))
                 }
                 else {
                     push(@cplx, undef)
                 }
             }
             my %args = (elements => [ @cplx ]);
             if ($object_info->{has_attributes}) {
                 $args{attributes} = { tagged_pairlist_to_attribute_hash(shift @args) };
             }
             mreturn(Statistics::R::REXP::Complex->new(%args))
         })
}


sub strsxp {
    my $object_info = shift;
    vector_and_attributes($object_info, object_content,
                          'Statistics::R::REXP::Character')
}


sub rawsxp {
    my $object_info = shift;
    return error "No attributes are allowed on raw vectors"
        if $object_info->{has_attributes};

    bind(with_count(maybe_long_length, \&any_uint8),
         sub {
             mreturn(Statistics::R::REXP::Raw->new(shift or return));
         })
}


sub vecsxp {
    my $object_info = shift;
    vector_and_attributes($object_info, object_content,
                          'Statistics::R::REXP::List')
}


sub expsxp {
    my $object_info = shift;
    vector_and_attributes($object_info, object_content,
                          'Statistics::R::REXP::Expression')
}


sub charsxp {
    my $object_info = shift;
    ## TODO: handle character set encodings (UTF8, LATIN1, native)
    bind(\&any_int32,
         sub {
             my $len = shift;
             if ($len >= 0) {
                 bind(count( $len, \&any_char),
                      sub {
                          my @chars = @{shift or return};
                          mreturn join('', @chars);
                      })
             } elsif ($len == -1) {
                 mreturn undef;
             } else {
                 error 'Negative length detected: ' . $len;
             }
         })
}


sub symsxp {
    my $object_info = shift;
    bind(object_content,        # should be followed by a charsxp
         sub {
             add_singleton(Statistics::R::REXP::Symbol->new(shift or return));
         })
}


sub refsxp {
    my $object_info = shift;
    my $ref_id = $object_info->{flags} >> 8;
    return error 'TODO: only packed reference ids' if $ref_id == 0;
    get_singleton($ref_id-1)
}


sub envsxp {
    my $object_info = shift;
    reserve_singleton(
        bind(\&any_uint32,
             sub {
                 my $locked = shift;
                 bind(count(4, object_content),
                      sub {
                          my ($enclosure, $frame, $hash, $attributes) = @{$_[0]};

                          ## Frame is a tagged pairlist with tag the symbol and CAR the value
                          my %vars = tagged_pairlist_to_rexp_hash $frame;

                          ## Hash table is a Null or a VECSXP with hash chain per element
                          if ($hash->can('elements')) {
                              ## It appears that a variable appears either in the frame *or*
                              ## in the hash table, so we have to merge the two
                              foreach my $chain (@{$hash->elements}) {
                                  ## Hash chain is a tagged pairlist
                                  my %chain_vars = tagged_pairlist_to_rexp_hash $chain;

                                  ## Merge the variables from the hash chain
                                  while (my ($name, $value) = each %chain_vars) {
                                      $vars{$name} = $value unless exists $vars{$name} and
                                          die "Variable $name is already defined in the environment";
                                  }
                              }
                          }

                          my %args = (
                              frame => \%vars,
                              enclosure => $enclosure,
                              );
                          if (ref $attributes eq ref []) {
                              $args{attributes} = { tagged_pairlist_to_attribute_hash $attributes };
                          }
                          mreturn(Statistics::R::REXP::Environment->new( %args ));
                      })
             }))
}

sub closxp {
    my $object_info = $_[0];

    bind(listsxp(@_),
         sub {
             my ($head, $body) = @{shift()};

             my $attributes = $head->{attributes};
             my $environment = $head->{tag};
             my $arguments = $head->{value};

             my (@arg_names, @arg_defaults);
             if (ref $arguments eq ref []) {
                 foreach my $arg (@{$arguments}) {
                     push @arg_names, $arg->{tag}->name;

                     my $default = $arg->{value};
                     if (Statistics::R::REXP::Symbol->new('') eq $default) {
                         push @arg_defaults, undef
                     }
                     else {
                         push @arg_defaults, $default
                     }
                 }
             }

             my %args = (
                 body => $body // Statistics::R::REXP::Null->new,
                 args => [@arg_names],
                 defaults => [@arg_defaults],
                 environment => $environment);
             if ($object_info->{has_attributes}) {
                 $args{attributes} = { tagged_pairlist_to_attribute_hash $attributes };
             }

             mreturn(Statistics::R::REXP::Closure->new( %args ));
         })
}


sub s4sxp {
    my $object_info = shift;
    bind(object_content,
         sub {
             my $attr = shift;
             my $attributes = { tagged_pairlist_to_attribute_hash($attr) };
             my $class = $attributes->{class}->elements;
             croak "S4 'class' must be a single-element array" unless
                 ref($class) eq 'ARRAY' && scalar(@{$class}) == 1;
             my $package = $attributes->{class}->attributes->{package}->elements;
             croak "S4 'package' must be a single-element array" unless
                 ref($package) eq 'ARRAY' && scalar(@{$package}) == 1;

             # the remaining attributes should be object's slots
             delete $attributes->{class};
             my $slots = $attributes;

             mreturn(Statistics::R::REXP::S4->new(class => $class->[0],
                                                  package => $package->[0],
                                                  slots => $slots))
         })
}


sub unserialize {
    my $data = shift;
    return error "Unserialize requires a scalar data" if ref $data && ref $data ne ref [];

    my $result =
        bind(header,
             \&object_content,
        )->(Statistics::R::IO::ParserState->new(data => $data));

    if ($result) {
        my $state = $result->[1];
        carp("remaining data: " . (scalar(@{$state->data}) - $state->position))
            unless $state->eof;
    }

    $result;
}


1;

__END__