view release on metacpan or  search on metacpan

lib/Data/ObjectStore.pm  view on Meta::CPAN

# returns the id of the refernce, injesting it if
# necessary.
# used by tests
sub _get_id {
  my( $self, $ref ) = @_;

  my $class = ref( $ref );
  my $thingy;
  if ( $class eq 'ARRAY' ) {
    $thingy = tied @$ref;
    if ( ! $thingy ) {
      my $id = $self->_new_id;
      my( @items ) = @$ref;
      tie @$ref, 'Data::ObjectStore::Array', $self, $id, { created => time, updated => time}, 0, $Data::ObjectStore::Array::MAX_BLOCKS;
      my $tied = tied @$ref;

      $self->_store_weak( $id, $ref );
      $self->_dirty( $id );
      push @$ref, @items;
      return $id;
    }
    $ref = $thingy;
    $class = ref( $ref );
  }
  elsif ( $class eq 'HASH' ) {
    $thingy = tied %$ref;
    if ( ! $thingy ) {
      my $id = $self->_new_id;
      my( %items ) = %$ref;
      tie %$ref, 'Data::ObjectStore::Hash', $self, $id,  { created => time, updated => time};
      my $tied = tied %$ref;

      $self->_store_weak( $id, $ref );
      $self->_dirty( $id );
      for my $key (keys( %items) ) {
        $ref->{$key} = $items{$key};
      }
      return $id;
    }
    $ref = $thingy;
    $class = ref( $ref );
  }
  else {
    $thingy = $ref;
  }

  die "Data::ObjectStore::_get_id : Cannot ingest object that is not a hash, array or objectstore obj" unless ( $class eq 'Data::ObjectStore::Hash' || $class eq 'Data::ObjectStore::Array' || $ref->isa( 'Data::ObjectStore::Container' ) ); # new id is ...

  return $ref->[ID];

} #_get_id

# END PACKAGE Data::ObjectStore

# --------------------------------------------------------------------------------

package Data::ObjectStore::Array;


##################################################################################
# This module is used transparently by ObjectStore to link arrays into its graph #
# structure. This is not meant to be called explicitly or modified.              #
##################################################################################

use strict;
use warnings;
use warnings FATAL => 'all';
no  warnings 'numeric';
no  warnings 'recursion';

use Tie::Array;

$Data::ObjectStore::Array::MAX_BLOCKS = 1_000_000;


use constant {
    ID          => 0,
    DATA        => 1,
    DSTORE      => 2,
    METADATA    => 3,
    LEVEL       => 4,
    BLOCK_COUNT => 5,
    BLOCK_SIZE  => 6,
    ITEM_COUNT  => 7,
    UNDERNEATH  => 8,

    WEAK         => 2,
};

sub store {
    shift->[DSTORE];
}

sub _freezedry {
    my $self = shift;
    my @items;
    my $stuff_count = $self->[BLOCK_COUNT] > $self->[ITEM_COUNT] ? $self->[ITEM_COUNT] : $self->[BLOCK_COUNT];
    if( $stuff_count > 0 ) {
        @items = map { if( defined($_) && $_=~ /[\\\`]/ ) { $_ =~ s/[\\]/\\\\/gs; s/`/\\`/gs; } defined($_) ? $_ : 'u' } map { $self->[DATA][$_] } (0..($stuff_count-1));
    }

    join( "`",
          $self->[LEVEL] || 0,
          $self->[BLOCK_COUNT],
          $self->[ITEM_COUNT] || 0,
          $self->[UNDERNEATH] || 0,
          @items,
        );
}

sub _reconstitute {
    my( $cls, $store, $id, $data, $meta ) = @_;
    my $arry = [];
    tie @$arry, $cls, $store, $id, $meta, @$data;
    return $arry;
}

sub TIEARRAY {
    my( $class, $obj_store, $id, $meta, $level, $block_count, $item_count, $underneath, @list ) = @_;
    $item_count //= 0;
    my $block_size  = $block_count ** $level;

lib/Data/ObjectStore.pm  view on Meta::CPAN

            $to_idx++;
            $from_idx++;
        }
    } # has things to remove

    if( @vals ) {
        #
        # while there are any in the insert list, grab all the items in the next block if any
        #    and append to the insert list, then splice in the insert list to the beginning of
        #    the block. There still may be items in the insert list, so repeat until it is done
        #

        my $block_idx = int( $offset / $BLOCK_SIZE );
        my $block_off = $offset % $BLOCK_SIZE;

        while( @vals && ($self->[ITEM_COUNT] > $block_idx*$BLOCK_SIZE+$block_off) ) {
            my $block = $self->_getblock( $block_idx );
            my $bubble_size = $block->FETCHSIZE - $block_off;
            if( $bubble_size > 0 ) {
                my @bubble = $block->SPLICE( $block_off, $bubble_size );
                push @vals, @bubble;
              }
            my $can_insert = @vals > ($BLOCK_SIZE-$block_off) ? ($BLOCK_SIZE-$block_off) : @vals;
            $block->SPLICE( $block_off, 0, splice( @vals, 0, $can_insert ) );
            $block_idx++;
            $block_off = 0;
        }
        while( @vals ) {
            my $block = $self->_getblock( $block_idx );
            my $remmy = $BLOCK_SIZE - $block_off;
            if( $remmy > @vals ) { $remmy = @vals; }

            $block->SPLICE( $block_off, $block->[ITEM_COUNT], splice( @vals, 0, $remmy) );
            $block_idx++;
            $block_off = 0;
        }

    } # has vals

    $self->_storesize( $new_size );

    return @removed;

} #SPLICE

sub EXTEND {
}

sub DESTROY {
    my $self = shift;
    delete $self->[DSTORE]->[WEAK]{$self->[ID]};
}

# END PACKAGE Data::ObjectStore::Array

# --------------------------------------------------------------------------------

package Data::ObjectStore::Hash;

##################################################################################
# This module is used transparently by ObjectStore to link hashes into its       #
# graph structure. This is not meant to  be called explicitly or modified.       #
##################################################################################

use strict;
use warnings;

no warnings 'uninitialized';
no warnings 'numeric';
no warnings 'recursion';

use Tie::Hash;

$Data::ObjectStore::Hash::BUCKET_SIZE = 29;
$Data::ObjectStore::Hash::MAX_SIZE = 1_062_599;

use constant {
    ID          => 0,
    DATA        => 1,
    DSTORE      => 2,
    METADATA    => 3,
    LEVEL       => 4,
    BUCKETS     => 5,
    SIZE        => 6,
    NEXT        => 7,
};

sub store {
    shift->[DSTORE];
}

sub _freezedry {
    my $self = shift;
    my $r = $self->[DATA];
    join( "`",
          $self->[LEVEL],
          $self->[BUCKETS],
          $self->[SIZE],
          map { if( $_=~ /[\\\`]/ ) { s/[\\]/\\\\/gs; s/`/\\`/gs; } $_ }
              $self->[LEVEL] ? @$r : %$r
        );
}

sub _reconstitute {
    my( $cls, $store, $id, $data, $meta ) = @_;
    my $hash = {};
    tie %$hash, $cls, $store, $id, $meta, @$data;

    return $hash;
}

sub TIEHASH {
    my( $class, $obj_store, $id, $meta, $level, $buckets, $size, @fetch_buckets ) = @_;
    $level //= 0;
    $size  ||= 0;
    unless( $buckets ) {
      $buckets = $Data::ObjectStore::Hash::BUCKET_SIZE;
    }
    bless [ $id,
            $level ? [@fetch_buckets] : {@fetch_buckets},
            $obj_store,