File Coverage

blib/lib/Persistent/Hash.pm

Criterion	Covered	Total	%
statement	120	299	40.1
branch	22	184	11.9
condition	0	12	0.0
subroutine	27	45	60.0
pod	0	13	0.0
total	169	553	30.5

#!/usr/bin/perl
package Persistent::Hash;

use strict;
use Carp qw(croak);
use Data::Dumper;

use vars qw($VERSION);
$VERSION = '0.5';

use Persistent::Hash::Dumper;

use constant DEBUG_LEVEL => 0;

use constant PROJECT => 'persistent-hash';

use constant INFO_TABLE => 'object_info';

use constant INDEX_TABLE => 'object_index';
use constant INDEX_FIELDS => [];

use constant DATA_TABLE => 'object_data';
use constant DATA_FIELDS => [];

use constant STRICT_FIELDS => 1;
use constant STORAGE_MODULE => 'Persistent::Hash::Storage::MySQL';

use constant STORABLE => 0;
use constant LOAD_ON_DEMAND => 1;
use constant SAVE_ONLY_IF_DIRTY => 0;

sub new
{
	my $classname = shift;
	return $classname->_instanciate(@_);
}

sub _instanciate
{
	my($classname, $args) = @_;

	my $self;
	#Create the untied hash

	#Tie the hash
	tie %$self, $classname;
	bless $self, $classname;

	my $untied_self = tied %$self;
	$untied_self->{_data_dirty} = 1;
	$untied_self->{_index_dirty} = 1;

	return $self;
}

sub load
{
	my ($classname, $id) = @_;

	croak "Attempt to call load() using a function call" if not defined $classname;
	croak "No id passed to load()" if not defined $id;
	croak "Argument to load() is not numeric" if not $id =~ /^[0-9]+$/;

	my $self = $classname->_instanciate();
	my $untied_self = tied %$self if tied %$self;
	die "Constructor error" if not defined $untied_self;

	my $storage_module = $untied_self->_PreloadStorageModule();

	my $object_info = $storage_module->LoadObjectInfo($classname, $id);
	if(not defined $object_info)
	{
		print STDERR "Could not load object id $id";
		return undef;
	}

	$untied_self->{_object_id} = $id;
	$untied_self->{_object_type} = $object_info->{type};
	$untied_self->{_time_created} = $object_info->{time_created};
	$untied_self->{_time_modified} = $object_info->{time_modified};

	if(not $self->LOAD_ON_DEMAND())
	{
		$untied_self->_Initialize();
	}

	return $self;
}

sub Id
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	$self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $self;

	return $self->{_object_id};
}

sub Type
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	return $self->PackageToType();
}

sub TimeCreated
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

	return $untied_self->{_time_created};
}

sub TimeModified
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

	return $untied_self->{_time_modified};
}
sub PackageToType
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $type = ref($self) ? ref($self) : $self;
	$type =~ s/::/_/g;

	$type = $self->PROJECT()."/".$type;

	return $type;
}

sub Save
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

	return undef if !$untied_self->STORABLE();
	return undef if !$untied_self->_IsDirty() && $untied_self->SAVE_ONLY_IF_DIRTY();

	my $storage_module = $untied_self->_PreloadStorageModule();

	if(!defined $untied_self->{_object_id})
	{
		my $object_id = $storage_module->InsertObject($self);
		croak "Object insertion failed!" if not defined $object_id;

		$untied_self->{_object_id} = $object_id;
		$untied_self->{_data_dirty} = 0;
		$untied_self->{_index_dirty} = 0;

		return $object_id;
	}
	else
	{
		my $object_id = $storage_module->UpdateObject($self);
		croak "Object update failed!" if not defined $object_id;

		$untied_self->{_data_dirty} = 0;
		$untied_self->{_index_dirty} = 0;

		return $object_id;
	}
}

sub Delete
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

	return undef if not $untied_self->STORABLE();
	return undef if not $untied_self->{_object_id};

	my $storage_module = $untied_self->_PreloadStorageModule();

	my $delete_status = $storage_module->DeleteObject($self);
	if($delete_status)
	{
		$untied_self = undef;
		untie %$self;
		return 1;
	}
	else
	{
		die "Object deletion error !";
	}

}

sub DatabaseHandle
{
	my $self = shift;

	croak "\nNo DatabaseHandle() function defined in ".ref($self)."\n";
}


sub InternalData
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

	return $untied_self;
}


sub Freezer
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

	my $id = $self->Id();

	if(not defined $id)
	{
		my $type = $self->Type();
		warn "Attempted to freeze an unsaved object instance of type $type";
	}

	my $package = ref($self);
	my $str = "do { use $package; scalar(load $package('$id')) }";
	return $str;
}

sub Dump
{
	my $self = shift;
	croak "No self reference!" if not defined $self;

	my $untied_self = tied %$self if tied %$self;
	croak "Wrong object side!" if not defined $untied_self;

   local $Data::Dumper::Indent=0;
   local $Data::Dumper::Useqq=1;
   local $Data::Dumper::Terse=1;
   local $Data::Dumper::Freezer = 'Freezer';

	my $d = 'Persistent::Hash::Dumper'->new( [$untied_self->{_data}] );
	my $str = $d->Dump();
	return $str;
}


#--#------------------------------------------#
# Internal API
#--#------------------------------------------#

sub _IsInitialized
{
	my $untied_self = shift;
	croak "Attempt to call _IsInitialized() as a function call" if not defined $untied_self;
	croak "Wrong object side!" if tied %$untied_self;

	return 1 if(not $untied_self->LOAD_ON_DEMAND());
	return 1 if(not defined $untied_self->{_object_id});
	return 1 if( defined $untied_self->{_object_id} && defined $untied_self->{_initialized});
	return undef;
}

sub _Initialize
{
	my $untied_self = shift;
	croak "Attempt to call _Initialize() as a function call" if not defined $untied_self;
	croak "Wrong object side!" if tied %$untied_self;

	return undef if not defined $untied_self->{_object_id};

	my $storage_module = $untied_self->_PreloadStorageModule();

	$untied_self->{_data} = $storage_module->LoadObjectData($untied_self);
	$untied_self->{_index_data} = $storage_module->LoadObjectIndex($untied_self);


	foreach my $key (keys %{$untied_self->{_data}})
	{
		delete $untied_self->{_data}->{$key} if !$untied_self->{_data_fields}->{$key} && $untied_self->STRICT_FIELDS();
		delete $untied_self->{_data}->{$key} if !defined $untied_self->{_data}->{$key};
	}

	foreach my $key (keys %{$untied_self->{_index_data}})
	{
		delete $untied_self->{_index_data}->{$key} if !$untied_self->{_index_fields}->{$key} && $untied_self->STRICT_FIELDS();
		delete $untied_self->{_index_data}->{$key} if !defined $untied_self->{_index_data}->{$key};
	}

	$untied_self->{_initialized} = 1;

	return 1;
}

sub _IsDirty
{
	my $untied_self = shift;
	croak "Attempt to call _IsDirty() as a function call" if not defined $untied_self;
	croak "Wrong object side!" if tied %$untied_self;

	#If any key in the hash is a ref to something, we are automatically
	#dirty because we can't track another ref's modifications.
	foreach my $key (keys %{$untied_self->{'_data'}})
	{
		$untied_self->{'_data_dirty'} = 1 if ref( $untied_self->{'_data'}->{$key} );
	}

	return 1 if $untied_self->{_index_dirty} == 1;
	return 1 if $untied_self->{_data_dirty} == 1;
	return undef;
}

sub _FlattenData
{
	my $untied_self = shift;
	croak "No self reference!" if not defined $untied_self;
	croak "Wrong object side!" if tied %$untied_self;

   local $Data::Dumper::Terse = 1;
	local $Data::Dumper::Indent = 0;
   local $Data::Dumper::Useqq = 1;

	my $dump = Dumper($untied_self->{_data});
	$dump =~ s/\$VAR1 =//g;

	return $dump;
}

sub _PreloadStorageModule
{
	my $untied_self = shift;
	croak "Attempt to call _IsDirty() as a function call" if not defined $untied_self;
	croak "Wrong object side!" if tied %$untied_self;

	return $untied_self->STORAGE_MODULE() if $untied_self->{_storage_module_preloaded};

	my $storage_module = $untied_self->STORAGE_MODULE();
	eval "use $storage_module";
	if($@)
	{
		die "Could not compile $storage_module";
	}
	$untied_self->{_storage_module_preloaded} = 1;
	return $untied_self->STORAGE_MODULE();
}

#--#------------------------------------------#
# Tie Hash implementation
#--#------------------------------------------#

sub TIEHASH
{
	my ($classname, $args) = @_;
	print STDERR "TIEHASH called.\n" if $classname->DEBUG_LEVEL();

	my $type = $classname->PackageToType();

	my $self =
	{
		_object_id => undef,
		_object_type => $type,
		_data => {},
		_data_fields => {},
		_data_dirty => 0,
		_index_data => {},
		_index_fields => {},
		_index_dirty => 0,
		_storage_module_preloaded => 0,
	};
	bless $self, $classname;

	return $self->_TieFields();
}

sub _TieFields
{
	my $self = shift;
	$self->{_index_fields} = {};
	$self->{_data_fields} = {};

	foreach my $field (@{$self->INDEX_FIELDS()})
	{
		$self->{_index_fields}->{$field} = 1;
	}

	foreach my $field (@{$self->DATA_FIELDS()})
	{
		$self->{_data_fields}->{$field} = 1;
	}
	return $self;
}

sub DELETE
{
	my $untied_self = shift;
	print STDERR "DELETE called.\n" if $untied_self->DEBUG_LEVEL();
	my $key = shift;

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();

	if($untied_self->{_index_fields}->{$key})
	{
		$untied_self->{_index_dirty} = 1;
		return delete $untied_self->{_index_data}->{$key};
	}
	elsif($untied_self->{_data_fields}->{$key})
	{
		$untied_self->{_data_dirty} = 1;
		return delete $untied_self->{_data}->{$key};
	}
	else
	{
		$untied_self->{_data_dirty} = 1;
		return delete $untied_self->{_data}->{$key};
	}
}

sub CLEAR
{
	my $untied_self = shift;
	print STDERR "CLEAR called.\n" if $untied_self->DEBUG_LEVEL();

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();

	$untied_self->{_index_dirty} = 1;
	$untied_self->{_index_data} = {};
	$untied_self->{_data_dirty} = 1;
	return $untied_self->{_data} = {};
}


sub STORE
{
	my $untied_self = shift;
	my $key = shift;
	my $value = shift;
	print STDERR "STORE called for $key: $value\n" if $untied_self->DEBUG_LEVEL();

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();

	if($untied_self->{_index_fields}->{$key})
	{
		$untied_self->{_index_dirty} = 1;
		return $untied_self->{_index_data}->{$key} = $value;
	}
	elsif($untied_self->{_data_fields}->{$key})
	{
		$untied_self->{_data_dirty} = 1;
		return $untied_self->{_data}->{$key} = $value;
	}
	elsif($untied_self->STRICT_FIELDS())
	{
		print STDERR "\nKey $key not allowed in a ".ref($untied_self)."\n";
		return undef;
	}
	else
	{
		$untied_self->{_data_dirty} = 1;
		return ($untied_self->{_data}->{$key} = $value);
	}
}

sub FETCH
{
	my $untied_self = shift;
	my $key = shift;
	print STDERR "FETCH called for $key\n" if $untied_self->DEBUG_LEVEL();

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();

	if($untied_self->STRICT_FIELDS())
	{
		if($untied_self->{_index_fields}->{$key})
		{
			return $untied_self->{_index_data}->{$key};
		}
		if($untied_self->{_data_fields}->{$key})
		{
			return $untied_self->{_data}->{$key};
		}
		return undef;
	}
	else
	{
		if($untied_self->{_index_fields}->{$key})
		{
			return $untied_self->{_index_data}->{$key};
		}
		return $untied_self->{_data}->{$key};
	}

}

sub EXISTS
{
	my $untied_self = shift;
	print STDERR "EXISTS called.\n" if $untied_self->DEBUG_LEVEL();
	my $key = shift;

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();

	if($untied_self->{_index_fields}->{$key})
	{
		return exists $untied_self->{_index_data}->{$key};
	}
	elsif($untied_self->{_data_fields}->{$key})
	{
		return exists $untied_self->{_data}->{$key};
	}
	else
	{
		return undef;
	}
}

sub NEXTKEY
{
	my $untied_self = shift;
	print STDERR "NEXTKEY called.\n" if $untied_self->DEBUG_LEVEL();

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();
	return pop @{$untied_self->{_keyslist}};
}

sub FIRSTKEY
{
	my $untied_self = shift;
	print STDERR "FIRSTKEY called.\n" if $untied_self->DEBUG_LEVEL();

	$untied_self->_Initialize() if not $untied_self->_IsInitialized();
	$untied_self->{_keyslist} =
	[
		(keys %{$untied_self->{_data}}),
		(keys %{$untied_self->{_index_data}})
	];

	return pop @{$untied_self->{_keyslist}};
}

666;