File Coverage

blib/lib/Ref/Store.pm

Criterion	Covered	Total	%
statement	279	426	65.4
branch	68	126	53.9
condition	13	27	48.1
subroutine	43	55	78.1
pod	15	32	46.8
total	418	666	62.7

package Ref::Store;
use strict;
use warnings;

our $VERSION = '0.15_0';

use Scalar::Util qw(weaken);
use Carp::Heavy;
use Ref::Store::Common;
use Ref::Store::Attribute;
use Ref::Store::Dumper;
use Scalar::Util qw(weaken isweak);
use Devel::GlobalDestruction;
use Data::Dumper;
use Log::Fu { level => "debug" };
use Carp qw(confess cluck);
use Devel::FindRef qw(ptr2ref);

use base qw(Ref::Store::Feature::KeyTyped Exporter);
our (@EXPORT,@EXPORT_OK,%EXPORT_TAGS);

use Constant::Generate [qw(
	REF_STORE_FALSE
	REF_STORE_TRUE

	REF_STORE_KEY
	REF_STORE_ATTRIBUTE

)], -tag => 'ref_store_constants',
	-export => 1,
	-export_tags => 1;

use Class::XSAccessor::Array
	accessors	=> {
        %Ref::Store::Common::LookupNames
    };

my %Tables; #Global hash of tables

################################################################################
################################################################################
################################################################################
### GENERIC FUNCTIONS                                                        ###
################################################################################
################################################################################
################################################################################
sub _keyfunc_defl {
	my $k = shift;
	if(ref $k) {
		return $k + 0;
	}
	return $k;
}

our $SelectedImpl;

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

	if($cls eq __PACKAGE__) {
		if(!defined $SelectedImpl) {
			log_debug("Will try to select best implementation");
			foreach (qw(XS PP Sweeping)) {
				my $impl = $cls . "::$_";
				eval "require $impl";
				if(!$@) {
					$SelectedImpl = $impl;
					last;
				}
			}
		}
		die "Can't load any implmented" unless $SelectedImpl;
		$cls = $SelectedImpl;
		log_debug("Using $SelectedImpl");
	}

	$options{keyfunc} ||= \&_keyfunc_defl;
	$options{unkeyfunc} ||= sub { $_[0] };

	my $self = [];
	bless $self, $cls;

	$self->[$_] = {} for
		(HR_TIDX_FLOOKUP,
		HR_TIDX_RLOOKUP,
		HR_TIDX_SLOOKUP,
		HR_TIDX_ALOOKUP,
		HR_TIDX_KEYTYPES);

	$self->[HR_TIDX_KEYFUNC] = $options{keyfunc};
	$self->[HR_TIDX_UNKEYFUNC] = $options{unkeyfunc};

	if($self->can('table_init')) {
		$self->table_init();
	}

	weaken($Tables{$self+0} = $self);
	return $self;
}

sub purge {
	my ($self,$value) = @_;
	return unless defined $value;
	my $vstring = $value + 0;

	foreach my $ko (values %{ $self->reverse->{$vstring} }) {
		if(!defined $ko) {
			die "Found stale key object!";
		}
		$ko->unlink_value($value);
	}

	$self->dref_del_ptr($value, $self->reverse, $value + 0);
	delete $self->reverse->{$vstring};
	return $value;
}

#Not fully implemented
sub exchange_value {
	my ($self,$old,$new) = @_;
	my $olds = $old+0;
	my $news = $new + 0;
	die "Can't switch to existing value!" if exists $self->reverse->{$news};

	return unless exists $self->reverse->{$olds};

	my $newh = {};
	my $oldh = $self->reverse->{$olds};
	$self->reverse->{$news} = $newh;

	while (my ($kaddr,$kobj) = each %$oldh) {
		$newh->{$kaddr} = $kobj;
		$kobj->exchange_value($old,$new);
		delete $oldh->{$kaddr};
	}
}

sub register_kt {
	my ($self,$kt,$id_prefix) = @_;
	if(!$self->keytypes) {
		$self->keytypes({});
	}
	$id_prefix ||= $kt;
	if(!exists $self->keytypes->{$kt}) {
		#log_info("Registering CONST=$kt PREFIX=$id_prefix");
		$self->keytypes->{$kt} = $id_prefix;
	}
}

sub maybe_cleanup_value {
	my ($self,$value) = @_;
	my $v_rhash = $self->reverse->{$value+0};
	if(!scalar %$v_rhash) {
		delete $self->reverse->{$value+0};
		$self->dref_del_ptr($value, $self->reverse, $value + 0);
	} else {
		#log_warn(scalar %$v_rhash);
	}
}

################################################################################
################################################################################
################################################################################
### INFORMATIONAL FUNCTIONS                                                  ###
################################################################################
################################################################################
################################################################################
sub has_key {
	my ($self,$key) = @_;
	$key = ref $key ? $key + 0 : $key;
	return (exists $self->forward->{$key} || exists $self->scalar_lookup->{$key});
}

*lexists = \&has_key;

sub has_value {
	my ($self,$value) = @_;
	return 0 if !defined $value;
	$value = $value + 0;
	return exists $self->reverse->{$value};
}

sub vlookups {
	my ($self,$value) = @_;
	my @ret;
	$value = $value + 0;
	my $vhash = $self->reverse->{$value};
	$vhash ||= {};
	foreach my $ko (values %$vhash) {
		push @ret, $ko->kstring;
	}
	return @ret;
}

*vexists = \&has_value;

sub has_attr {
	my ($self,$attr,$t) = @_;
	$self->attr_get($attr, $t);
}

sub is_empty {
	my $self = shift;
	%{$self->scalar_lookup} == 0
		&& %{$self->reverse} == 0
		&& %{$self->forward} == 0
		&& %{$self->attr_lookup} == 0;
}

sub vlist {
	my $self = shift;
	return map { Devel::FindRef::ptr2ref $_+0 } keys %{ $self->reverse };
}

sub _mk_keyspec {
	my $lookup = shift;
	my $prefix;
	my $kstring = $lookup->kstring;
	my $ukey = $lookup->ukey;
	$ukey = $kstring unless defined $ukey;
	if($lookup->prefix_len) {
		$prefix = substr($kstring, 0, $lookup->prefix_len);
		if(!ref $ukey) {
			$ukey = substr($kstring, $lookup->prefix_len+1);
		}
	} else {
		$prefix = "";
	}
	return ($prefix, $ukey);
}

sub klist {
	my ($self,%options) = @_;
	my @ret;
	foreach my $kobj (values %{$self->forward}) {
		push @ret, [REF_STORE_KEY, _mk_keyspec($kobj)];
	}
	foreach my $aobj (values %{$self->attr_lookup}) {
		push @ret, [REF_STORE_ATTRIBUTE, _mk_keyspec($aobj)];
	}
	return @ret;
}


#This is the iteration mechanism. An 'iterator' is an internal structure
#which keeps track of the items we wish to iterate over. the CUR field
#is a simple integer. the HASH field is an array of hashrefs, with the
#current active hash specified with the CUR field; thus the currently
#iterated-over hash is $iter->[ITER_FLD_HASH]->[ $iter->[ITER_FLD_CUR] ];
# When the CUR field reaches ITER_CUR_END, it means there are no more
#hashes to iterate over.
use constant {
	ITER_FLD_HASH 	=> 0,
	ITER_FLD_CUR	=> 1,

	ITER_CUR_KEYS	=> 0,
	ITER_CUR_ATTR	=> 1,
	ITER_CUR_END	=> 2
};
sub iterinit {
	my ($self,%options) = @_;

	warn("Resetting existing non-null iterator") if defined $self->_iter;

	keys %{$self->scalar_lookup};
	keys %{$self->attr_lookup};
	my $iter = [];
	$iter->[ITER_FLD_CUR] = 0;

	$iter->[ITER_FLD_HASH]->[ITER_CUR_KEYS] = $self->scalar_lookup;
	$iter->[ITER_FLD_HASH]->[ITER_CUR_ATTR] = $self->attr_lookup;

	if($options{OnlyKeys}) {
		delete $iter->[ITER_FLD_HASH]->[ITER_CUR_ATTR];
	} elsif ($options{OnlyAttrs}) {
		delete $iter->[ITER_FLD_HASH]->[ITER_CUR_KEYS];
		$iter->[ITER_FLD_CUR]++;
	}
	$self->_iter($iter);
	return;
}

sub iterdone {
	my $self = shift;
	$self->_iter(undef);
}

sub iter {
	my $self = $_[0];
	my $iter = $self->_iter;
	return unless $iter;
	my @ret;
	#print Dumper($iter);
	my $nextk = each %{$iter->[ITER_FLD_HASH]->[ $iter->[ITER_FLD_CUR] ] };
	goto GT_EMPTY unless defined $nextk;

	my $lookup = $iter->[ITER_FLD_HASH]->[ $iter->[ITER_FLD_CUR] ]->{$nextk};

	goto GT_EMPTY unless defined $lookup;



	if($iter->[ITER_FLD_CUR] == ITER_CUR_KEYS) {
		@ret = (REF_STORE_KEY,
				_mk_keyspec($lookup),
				$self->forward->{$lookup->kstring});
	} else {
		#Attribute
		@ret = (REF_STORE_ATTRIBUTE,
				_mk_keyspec($lookup),
				[values %{$lookup->get_hash}]);
	}
	return @ret;

	GT_EMPTY:
	while($iter->[ITER_FLD_CUR]++ < ITER_CUR_END) {
		if($iter->[ITER_FLD_HASH]->[ $iter->[ITER_FLD_CUR ] ]) {
			goto &iter;
		}
	}
	#End!
	$self->_iter(undef);
	return ();
}

sub dump {
	my $self = shift;
	my $dcls = "Ref::Store::Dumper";
	my $hrd = $dcls->new();
	#my $hrd = Ref::Store::Dumper->new();
	#log_err($hrd);
	$hrd->dump($self);
	$hrd->flush();
	#print Dumper($self);
}
################################################################################
################################################################################
################################################################################
### KEY FUNCTIONS                                                            ###
################################################################################
################################################################################
################################################################################
sub new_key {
	die "new_key not implemented!";
}

sub ukey2ikey {
	my ($self, $ukey, %options) = @_;

	my $ustr = $self->keyfunc->($ukey);
	my $expected = delete $options{O_EXCL};
	my $create_if_needed = delete $options{Create};

	#log_info($ustr);
	my $o = $self->scalar_lookup->{$ustr};
	if($expected && $o) {
		my $existing = $self->forward->{$o->kstring};
		if($existing && $expected != $existing) {
			die "Request O_EXCL for new key ${\$o->kstring} => $expected but key ".
			"is already tied to $existing";
		}
	}

	if(!$o && $create_if_needed) {
		$o = $self->new_key($ukey);
		if(!$options{StrongKey}) {
			$o->weaken_encapsulated();
		}
	}

	return $o;
}

sub store_sk {
	my ($self,$ukey,$value,%options) = @_;
	my $o = $self->ukey2ikey($ukey,
		Create => 1,
		O_EXCL => $value,
		%options
	);
	my $vstring = $value+0;
	my $kstring = $o->kstring;
	$self->reverse->{$vstring}->{$kstring} = $o;
	$self->forward->{$kstring} = $value;

	#Add a back-delete to the reverse entry. The forward
	#entry for keys are handled by the keys themselves.
	$self->dref_add_ptr($value, $self->reverse);
	$o->link_value($value);

	if(!$options{StrongValue}) {
		weaken($self->forward->{$kstring});
	}
	return $value;
}
*store = \&store_sk;


#sub store_kt {
#	my ($self,$ukey,$prefix,$value,%options) = @_;
#
#}

sub fetch_sk {
	my ($self,$ukey) = @_;
	#log_info("called..");
	my $o = $self->ukey2ikey($ukey);
	return unless $o;
	return $self->forward->{$o->kstring};
}
*fetch = \&fetch_sk;

#This dissociates a value from a single key
sub unlink_sk {
	my ($self,$ukey) = @_;

	my $ko = $self->ukey2ikey($ukey);
	return unless $ko;
	my $value = $self->forward->{$ko->kstring};
	die "Found orphaned key $ko" unless defined $value;

	my $vstr = $value + 0;
	my $kstr = $ko->kstring;

	my $vhash = $self->reverse->{$vstr};

	die "Can't locate vhash" unless defined $vhash;
	delete $vhash->{$kstr};

	$ko->unlink_value($value);

	if(!%{$self->reverse->{$vstr}}) {
		delete $self->reverse->{$vstr};
		$self->dref_del_ptr($value, $self->reverse, $vstr);

	}

	return $value;
}
*unlink = \&unlink_sk;

sub purgeby_sk {
	my ($self,$kspec) = @_;
	my $value = $self->fetch($kspec);
	return unless $value;
	$self->purge($value);
	return $value;
}

*purgeby = \&purgeby_sk;

*lexists_sk = \&lexists;

################################################################################
################################################################################
################################################################################
### ATTRIBUTE FUNCTIONS                                                      ###
################################################################################
################################################################################
################################################################################
sub new_attr {
	my ($self,$astr,$attr) = @_;
	my $cls = ref $attr ? 'Ref::Store::Attribute::Encapsulating' :
		'Ref::Store::Attribute';
	$cls->new($astr,$attr,$self);
}

sub attr_get {
    my ($self,$attr,$t,%options) = @_;

    my $ustr = $self->keytypes->{$t} or die "Couldn't find attribtue type!";
    $ustr .= "#";
    if(ref $attr) {
        $ustr .= $attr+0;
    } else {
        die unless $attr;
        $ustr .= $attr;
    }
    my $aobj = $self->attr_lookup->{$ustr};
    return $aobj if $aobj;

    if(!$options{Create}) {
        return;
    }

    $aobj = $self->new_attr($ustr, $attr, $self);
	weaken($self->attr_lookup->{$ustr} = $aobj);

    if(!$options{StrongAttr}) {
		$aobj->weaken_encapsulated();
    }
    return $aobj;
}

sub store_a {
    my ($self,$attr,$t,$value,%options) = @_;

    my $aobj = $self->attr_get($attr, $t, Create => 1, %options);
	if(!$value) {
		log_err(@_);
		die "NULL Value!";
	}

    my $vaddr = $value + 0;

	$self->reverse->{$vaddr}->{$aobj+0} = $aobj;

    if(!$options{StrongValue}) {
        $aobj->store_weak($vaddr, $value);
    } else {
        $aobj->store_strong($vaddr, $value);
    }

    #add back-delete references to both the private
    #attribute hash as well as the reverse entry.

    $self->dref_add_ptr($value, $aobj->get_hash);
    $self->dref_add_ptr($value, $self->reverse);
    $aobj->link_value($value);

    return $value;
}

#sub tag {
#	my ($self,$tag,$value, %options) = @_;
#	$self->store_a(1, $tag, $value, %options);
#}
#
#sub untag {
#	my ($self,$tag,$value,%options) = @_;
#	$self->dissoc_a(1, $tag, $value);
#}



sub fetch_a {
    my ($self,$attr,$t) = @_;
    my $aobj = $self->attr_get($attr, $t);
	if(!$aobj) {
		#log_err("Can't find attribute object! ($attr:$t)");
		#print Dumper($self->attr_lookup);
		return;
	}
	my @ret;
	return @ret unless $aobj;
	@ret = values %{$aobj->get_hash};
	return @ret;
}

sub purgeby_a {
    my ($self,$attr,$t) = @_;
    my @values = $self->fetch_a($attr, $t);
    $self->purge($_) foreach @values;
	return @values;
}

sub dissoc_a {
    my ($self,$attr,$t,$value) = @_;
    my $aobj = $self->attr_get($attr, $t);
	if(!$aobj) {
		log_err("Can't find attribute for $t$attr");
		return;
	}
	my $attrhash = $aobj->get_hash;
	delete $attrhash->{$value+0};
	delete $self->reverse->{$value+0}->{$aobj+0};
	$self->dref_del_ptr($value, $attrhash, $value+0);

	$aobj->unlink_value($value);
	$self->maybe_cleanup_value($value);
}

sub unlink_a {
    my ($self,$attr,$t) = @_;
    my $aobj = $self->attr_get($attr, $t);
	my $attrhash = $aobj->get_hash;
    return unless $attrhash;


	while (my ($k,$v) = each %$attrhash) {
		$self->dref_del_ptr($v, $attrhash, $v+0);
		delete $attrhash->{$k};
		delete $self->reverse->{$v+0}->{$aobj+0};
		$aobj->unlink_value($v);
		$self->maybe_cleanup_value($v);
	}
}


*lexists_a = \&has_attr;

sub Dumperized {
	my $self = shift;
	return {
		"This is the Toaster method" => "NOTICE!",

		'Reverse Lookups' => $self->reverse,
		'Forward Lookups' => $self->forward,
		'Scalar Lookups' => $self->scalar_lookup,
		'Attribute Lookups' => $self->attr_lookup
	};
}

sub DESTROY {
	return if in_global_destruction;
	my $self = shift;
	my @values;
	foreach my $attr (values %{$self->attr_lookup}) {
		foreach my $v (values %{$attr->get_hash}) {
			next unless defined $v;
			if($attr->can('unlink_value')) {
				$attr->unlink_value($v);
			}
			push @values, $v;
		}
	}

	foreach my $kobj (values %{$self->scalar_lookup}) {
		my $v = $self->forward->{$kobj->kstring};
		push @values, $v;
		if($kobj->can("unlink_value")) {
			$kobj->unlink_value($v);
		}
		delete $self->scalar_lookup->{$kobj->kstring};
		delete $self->forward->{$kobj->kstring};
	}

	foreach my $value (@values) {
		delete $self->reverse->{$value+0};
		$self->dref_del_ptr($value, $self->reverse, $value + 0);
	}
	undef @values;

	delete $Tables{$self+0};
}

################################################################################
################################################################################
### Thread Cloning                                                           ###
################################################################################
################################################################################

#This maps addresses to (weak) object references
our %CloneAddrs;

sub ithread_predup {
	my $self = shift;

	$self->ithread_store_lookup_info(\%CloneAddrs);

	#Key lookups
	foreach my $val (values %{$self->forward}) {
		weaken($CloneAddrs{$val+0} = $val);
	}

	foreach my $kobj (values %{$self->scalar_lookup}) {
		weaken($CloneAddrs{$kobj+0} = $kobj);

		my $v = $self->forward->{$kobj->kstring};
		$kobj->ithread_predup($self, \%CloneAddrs, $v);
	}

	foreach my $attr (values %{$self->attr_lookup}) {
		weaken($CloneAddrs{$attr+0} = $attr);
		$attr->ithread_predup($self, \%CloneAddrs);
		foreach my $v (values %{$attr->get_hash}) {
			weaken($CloneAddrs{$v+0} = $v);
		}
	}

	foreach my $vhash (values %{$self->reverse}) {
		weaken($CloneAddrs{$vhash+0} = $vhash);
	}
}

sub ithread_postdup {
	my ($self,$old_table) = @_;

	my @oldkeys = keys %{$self->reverse};
	foreach my $oldaddr (@oldkeys) {
		my $vhash = $self->reverse->{$oldaddr};
		my $vobj = $CloneAddrs{$oldaddr};
		if(!defined $vobj) {
			print Dumper(\%CloneAddrs);
			die("KEY=$oldaddr");
		}
		my $newaddr = $vobj + 0;
		$self->reverse->{$newaddr} = $vhash;
		delete $self->reverse->{$oldaddr};
		$self->dref_add_ptr($vobj, $self->reverse, $newaddr);
	}

	@oldkeys = keys %{$self->scalar_lookup};
	foreach my $kstring (@oldkeys) {
		my $kobj = $self->scalar_lookup->{$kstring};
		$kobj->ithread_postdup($self, \%CloneAddrs, $old_table);
		my $new_kstring = $kobj->kstring;

		next unless $new_kstring ne $kstring;
		my $weak_key = isweak($self->scalar_lookup->{$kstring});
		my $weak_val = isweak($self->forward->{$kstring});

		delete $self->scalar_lookup->{$kstring};
		my $v = delete $self->forward->{$kstring};

		$self->scalar_lookup->{$new_kstring} = $kobj;
		$self->forward->{$new_kstring} = $v;

		if($weak_key) {
			weaken($self->scalar_lookup->{$new_kstring});
		}
		if($weak_val) {
			weaken($self->forward->{$new_kstring});
		}
	}

	@oldkeys = keys %{$self->attr_lookup};
	foreach my $astring (@oldkeys) {
		my $aobj = $self->attr_lookup->{$astring};
		$aobj->ithread_postdup($self, \%CloneAddrs);
		my $new_astring = $aobj->kstring;

		next unless $new_astring ne $astring;

		delete $self->attr_lookup->{$astring};
		weaken($self->attr_lookup->{$new_astring} = $aobj);
	}
}

$SIG{__DIE__}=\&confess;
sub CLONE_SKIP {
	my $pkg = shift;
	return 0 if $pkg ne __PACKAGE__;
	%CloneAddrs = ();

	while ( my ($addr,$obj) = each %Tables ) {
		if(!defined $obj) {
			log_err("Found undefined reference T=$addr");
			#die("Found undef table in hash");
			delete $Tables{$addr};
			next;
		}
		$obj->ithread_predup();
	}

	return 0;
}

sub CLONE {
	my $pkg = shift;
	return if $pkg ne __PACKAGE__;

	my @tkeys = keys %Tables;
	my @new_tables;
	foreach my $old_taddr (@tkeys) {
		my $table = delete $Tables{$old_taddr};
		#log_info("Calling ithread_postdup on table");
		$table->ithread_postdup($old_taddr);
		#log_info("Done");
		weaken($Tables{$table+0} = $table);
	}

	%CloneAddrs = ();
}
1;

__END__