File Coverage

blib/lib/PDLA/IO/Storable.pm

Criterion	Covered	Total	%
statement	78	88	88.6
branch	21	40	52.5
condition	6	15	40.0
subroutine	11	12	91.6
pod	0	7	0.0
total	116	162	71.6

#
# GENERATED WITH PDLA::PP! Don't modify!
#
package PDLA::IO::Storable;

@EXPORT_OK  = qw( );
%EXPORT_TAGS = (Func=>[@EXPORT_OK]);

use PDLA::Core;
use PDLA::Exporter;
use DynaLoader;




   @ISA    = ( 'PDLA::Exporter','DynaLoader' );
   push @PDLA::Core::PP, __PACKAGE__;
   bootstrap PDLA::IO::Storable ;









=head1 NAME

PDLA::IO::Storable - helper functions to make PDLA usable with Storable

=head1 SYNOPSIS

  use Storable;
  use PDLA::IO::Storable;
  $hash = {
            'foo' => 42,
            'bar' => zeroes(23,45),
          };
  store $hash, 'perlhash.dat';

=head1 DESCRIPTION

C implements object persistence for Perl data structures that can
contain arbitrary Perl objects. This module implements the relevant methods to
be able to store and retrieve piddles via Storable.

=head1 FUNCTIONS

=cut




use Carp;

{ package # hide from PAUSE
    PDLA;
# routines to make PDLA work with Storable >= 1.03

# pdlpack() serializes a piddle, while pdlunpack() unserializes it. Earlier
# versions of PDLA didn't control for endianness, type sizes and enumerated type
# values; this made stored data unportable across different architectures and
# PDLA versions. This is no longer the case, but the reading code is still able
# to read the old files. The old files have no meta-information in them so it's
# impossible to read them correctly with 100% accuracy, but we try to make an
# educated guess
#
# Old data format:
#
#  int type
#  int ndims
#  int dims[ndims]
#  data
#
# Note that here all the sizes and endiannesses are the native. This is
# un-portable. Furthermore, the "type" is an enum, and its values could change
# between PDLA versions. Here I assume that the old format input data is indeed
# native, so the old data files have the same portability issues, but at least
# things will remain working and broken in the same way they were before
#
#
# New format:
#
#  uint64 0xFFFF FFFF FFFF FFFF # meant to be different from the old-style data
#  char type[16]                # ' '-padded, left-aligned type string such as 'PDLA_LL'
#  uint32 sizeof(type)          # little-endian
#  uint32 one                   # native-endian. Used to determine the endianness
#  uint64 ndims                 # little-endian
#  uint64 dims[ndims]           # little-endian
#  data
#
# The header data is all little-endian here. The data is stored with native
# endianness. On load it is checked, and a swap happens, if it is required

sub pdlpack {
  my ($pdl) = @_;

  my $hdr = pack( 'c8A16VL',
                  (-1) x 8,
                  $pdl->type->symbol,
                  PDLA::Core::howbig( $pdl->get_datatype ), 1 );

  # I'd like this to be simply
  #   my $dimhdr = pack( 'Q<*', $pdl->getndims, $pdl->dims )
  # but my pack() may not support Q, so I break it up manually
  #
  # if sizeof(int) == 4 here, then $_>>32 will not return 0 necessarily (this in
  # undefined). I thus manually make sure this is the case
  #
  my $noMSW = (PDLA::Core::howbig($PDLA::Types::PDLA_IND) < 8) ? 1 : 0;
  my $dimhdr = pack( 'V*',
                     map( { $_ & 0xFFFFFFFF, $noMSW ? 0 : ($_ >> 32) } ($pdl->getndims, $pdl->dims ) ) );

  my $dref = $pdl->get_dataref;
  return $hdr . $dimhdr . $$dref;
}

sub pdlunpack {
  use Config ();
  my ($pdl,$pack) = @_;

  my ($type, $ndims);
  my @dims = ();

  my $do_swap = 0;

  # first I try to infer the type of this storable
  my $offset = 0;
  my @magicheader = unpack( "ll", substr( $pack, $offset ) );
  $offset += 8;

  if( $magicheader[0] != -1 ||
      $magicheader[1] != -1 )
  {
    print "PDLA::IO::Storable detected an old-style pdl\n" if $PDLA::verbose;

    # old-style data. I leave the data sizes, endianness native, since I don't
    # know any better. This at least won't break anything.
    #
    # The "type" however needs attention. Most-recent old-format data had these
    # values for the type:
    #
    #  enum { byte,
    #         short,
    #         unsigned short,
    #         long,
    #         long long,
    #         float,
    #         double }
    #
    # The $type I read from the file is assumed to be in this enum even though
    # PDLA may have added other types in the middle of this enum.
    my @reftypes = ($PDLA::Types::PDLA_B,
                    $PDLA::Types::PDLA_S,
                    $PDLA::Types::PDLA_U,
                    $PDLA::Types::PDLA_L,
                    $PDLA::Types::PDLA_LL,
                    $PDLA::Types::PDLA_F,
                    $PDLA::Types::PDLA_D);

    my $stride = $Config::Config{intsize};
    ($type,$ndims) = unpack 'i2', $pack;
    @dims = $ndims > 0 ? unpack 'i*', substr $pack, 2*$stride,
      $ndims*$stride : ();

    $offset = (2+$ndims)*$stride;

    if( $type < 0 || $type >= @reftypes )
    {
      croak "Reading in old-style pdl with unknown type: $type. Giving up.";
    }
    $type = $reftypes[$type];
  }
  else
  {
    print "PDLA::IO::Storable detected a new-style pdl\n" if $PDLA::verbose;

    # new-style data. I KNOW the data sizes, endianness and the type enum
    my ($typestring) = unpack( 'A16', substr( $pack, $offset ) );
    $offset += 16;

    $type = eval( '$PDLA::Types::' . $typestring );
    if( $@ )
    {
      croak "PDLA::IO::Storable couldn't parse type string '$typestring'. Giving up";
    }

    my ($sizeof) = unpack( 'V', substr( $pack, $offset ) );
    $offset += 4;
    if( $sizeof != PDLA::Core::howbig( $type ) )
    {
      croak
        "PDLA::IO::Storable sees mismatched data type sizes when reading data of type '$typestring'\n" .
        "Stored data has sizeof = $sizeof, while here it is " . PDLA::Core::howbig( $type ) . ".\n" .
        "Giving up";
    }

    # check the endianness, if the "1" I read is interpreted as "1" on my
    # machine then the endiannesses match, and I can just read the data
    my ($one) = unpack( 'L', substr( $pack, $offset ) );
    $offset += 4;

    if( $one == 1 )
    {
      print "PDLA::IO::Storable detected matching endianness\n" if $PDLA::verbose;
    }
    else
    {
      print "PDLA::IO::Storable detected non-matching endianness. Correcting data on load\n" if $PDLA::verbose;

      # mismatched endianness. Let's make sure it's a big/little issue, not
      # something weird. If mismatched, the '00000001' should be seen as
      # '01000000'
      if( $one != 0x01000000 )
      {
        croak
          "PDLA::IO::Storable sees confused endianness. A '1' was read as '$one'.\n" .
          "This is neither matching nor swapped endianness. I don't know what's going on,\n" .
          "so I'm giving up."
      }

      # all righty. Everything's fine, but I need to swap all the data
      $do_swap = 1;
    }



    # mostly this acts like unpack('Q<'...), but works even if my unpack()
    # doesn't support 'Q'. This also makes sure that my PDLA_Indx is large enough
    # to read this piddle
    sub unpack64bit
    {
      my ($count, $pack, $offset) = @_;

      return map
      {
        my ($lsw, $msw) = unpack('VV', substr($$pack, $$offset));
        $$offset += 8;

        croak( "PDLA::IO::Storable tried reading a file with dimensions that don't fit into 32 bits.\n" .
               "However here PDLA_Indx can't store a number so large. Giving up." )
          if( PDLA::Core::howbig($PDLA::Types::PDLA_IND) < 8 && $msw != 0 );

        (($msw << 32) | $lsw)
      } (1..$count);
    }

    ($ndims) = unpack64bit( 1, \$pack, \$offset );
    @dims = unpack64bit( $ndims, \$pack, \$offset ) if $ndims > 0;
  }

  print "thawing PDLA, Dims: [",join(',',@dims),"]\n" if $PDLA::verbose;
  $pdl->make_null; # make this a real piddle -- this is the tricky bit!
  $pdl->set_datatype($type);
  $pdl->setdims([@dims]);
  my $dref = $pdl->get_dataref;

  $$dref = substr $pack, $offset;
  if( $do_swap && PDLA::Core::howbig( $type ) != 1 )
  {
    swapEndian( $$dref, PDLA::Core::howbig( $type ) );
  }
  $pdl->upd_data;
  return $pdl;
}

sub STORABLE_freeze {
  my ($self, $cloning) = @_;
#  return if $cloning;         # Regular default serialization
  return UNIVERSAL::isa($self, "HASH") ? ("",{%$self}) # hash ref -> Storable
    : (pdlpack $self); # pack the piddle into a long string
}

sub STORABLE_thaw {
  my ($pdl,$cloning,$serial,$hashref) = @_;
  # print "in STORABLE_thaw\n";
#  return if $cloning;
  my $class = ref $pdl;
  if (defined $hashref) {
    croak "serial data with hashref!" unless !defined $serial ||
      $serial eq "";
    for (keys %$hashref) { $pdl->{$_} = $hashref->{$_} }
  } else {
    # all the magic is happening in pdlunpack
    $pdl->pdlunpack($serial); # unpack our serial into this sv
  }
}

# have these as PDLA methods

=head2 store

=for ref

store a piddle using L

=for example

  $x = random 12,10;
  $x->store('myfile');

=cut

=head2 freeze

=for ref

freeze a piddle using L

=for example

  $x = random 12,10;
  $frozen = $x->freeze;

=cut

sub store  { require Storable; Storable::store(@_) }
sub freeze { require Storable; Storable::freeze(@_) }
}

=head1 AUTHOR

Copyright (C) 2013 Dima Kogan
Copyright (C) 2002 Christian Soeller
All rights reserved. There is no warranty. You are allowed
to redistribute this software / documentation under certain
conditions. For details, see the file COPYING in the PDLA
distribution. If this file is separated from the PDLA distribution,
the copyright notice should be included in the file.

=cut




;



# Exit with OK status

1;