view release on metacpan or  search on metacpan

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

package Data::ObjectStore;

use strict;
use warnings;

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

use File::Path qw( make_path );
use Scalar::Util qw(weaken);
use Time::HiRes qw(time);
use vars qw($VERSION);

use Data::RecordStore;
use Data::ObjectStore::Cache;

$VERSION = '2.13';

our $DEBUG = 0;
our $UPGRADING;

use constant {
    DATA_PROVIDER => 0,
    DIRTY         => 1,
    WEAK          => 2,
    STOREINFO     => 3,
    OPTIONS       => 4,
    CACHE         => 5,
    
    ID       => 0,
    DATA     => 1,
    METADATA => 3,
    LEVEL    => 4,
    DIRTY_BIT => 5,  #for objs
};
my( @METAFIELDS ) = qw( created updated );

sub open_store {
    my( $cls, @options ) = @_;

    die "Data::ObjectStore->open_store requires at least one argument" if 0 == @options;
    
    if( 1 == @options ) {
        unshift @options, 'DATA_PROVIDER';
    }
    my( %options ) = @options;

    my $data_provider = $options{DATA_PROVIDER};
    if( ! ref( $data_provider ) ) {
        # the default record store Data::RecordStore
        $options{BASE_PATH} = "$data_provider/RECORDSTORE";
        $data_provider = Data::RecordStore->open_store( %options );
    }
    my $cache = $options{CACHE} ? ref( $options{CACHE} ) ? $options{CACHE} : Data::ObjectStore::Cache->new( $options{CACHE} ) : undef;
    my $store = bless [
        $data_provider,
        {}, #DIRTY CACHE
        {}, #WEAK CACHE
        undef,
        \%options,
        $cache,
      ], $cls;

    if( ! $UPGRADING ) {
        $store->[STOREINFO] = $store->_fetch_store_info_node;
        $store->load_root_container;
        if( $store->get_store_version < 1.2  ) {
            die "Unable to open store of version ".$store->get_store_version.". Please run upgrade_store.";
        }
        $store->save;

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

              } else {
                  die "Object in the store was marked as '$class' but that is not a 'Data::ObjectStore::Container'";
              }
          }
      };
      if( $@ ) {
          if( $force ) {
              warn "Forcing '$class' to be 'Data::ObjectStore::Container'";
              $class = 'Data::ObjectStore::Container';
          } else {
              die $@;
          }
      }
    }

    my $pieces = _thaw( $dryfroze );

    my $ret = $class->_reconstitute( $self, $id, $pieces, $meta );
    $self->_store_weak( $id, $ret );
    return $ret;
} #_fetch

#
# Convert from reference, scalar or undef to value marker
#
sub _xform_in {
    my( $self, $val ) = @_;
    if( ref( $val ) ) {
        my $id = $self->_get_id( $val );
        return $id, "r$id";
    }
    return 0, (defined $val ? "v$val" : 'u');
}

#
# Convert from value marker to reference, scalar or undef
#
sub _xform_out {
    my( $self, $val ) = @_;

    return undef unless defined( $val ) && $val ne 'u';

    if( index($val,'v') == 0 ) {
        return substr( $val, 1 );
    }
    if( $val =~ /^r(\d+)/ ) {
        return $self->fetch( $1 );
    }
    return $self->fetch( $val );
}

sub _store_weak {
    my( $self, $id, $ref ) = @_;

    if( $self->[CACHE] ) {
        $self->[CACHE]->stow( $id, $ref );
    }
    
    $self->[WEAK]{$id} = $ref;

    weaken( $self->[WEAK]{$id} );

} #_store_weak

sub _dirty {
    my( $self, $id ) = @_;
    my $item = $self->[WEAK]{$id};
    $self->[DIRTY]{$id} = $item;
    $item = $self->_knot( $item );
    if( $item ) {
        $item->[METADATA]{updated} = time();
    }
} #_dirty


sub _new_id {
    my( $self ) = @_;
    my $newid = $self->[DATA_PROVIDER]->next_id;
    $newid;
} #_new_id

sub _meta {
    my( $self, $thingy ) = @_;
    return {
      created => $thingy->[METADATA]{created},
      updated => $thingy->[METADATA]{updated},
    };
} #_meta

sub last_updated {
  my( $self, $obj ) = @_;
  $obj = $self->_knot( $obj );
  return undef unless $obj;
  $self->_meta( $obj )->{updated};
}

sub created {
  my( $self, $obj ) = @_;
  $obj = $self->_knot( $obj );
  return undef unless $obj;
  $self->_meta( $obj )->{created};
}

# 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 );