weaken results from the CPAN

Basset

package Basset::Object::Persistent;

#Basset::Object::Persistent Copyright and (c) 2000, 2002, 2003, 2004, 2005, 2006 James A Thomason III
#Basset::Object::Persistent is distributed under the terms of the Perl Artistic License.

our $VERSION = '1.03';

=pod

=head1 NAME

Basset::Object::Persistent - subclass of Basset::Object that allows objects to be easily stored into a relational database.
Presently only supports MySQL, but that may change in the future.

=head1 AUTHOR

Jim Thomason, jim@jimandkoka.com

=head1 SYNOPSIS

(no synopsis, this is an abstract super class that should never be instantiated directly, it should be subclassed for all
persistent objects and used through them)

=head1 DESCRIPTION

Basset::Object is the uber module in my Perl world. All objects should decend from Basset::Object. It handles defining attributes,
error handling, construction, destruction, and generic initialization. It also talks to Basset::Object::Conf to allow conf file use.

But, some objects cannot simply be recreated constantly every time a script runs. Sometimes you need to store the data in an object
between uses so that you can recreate an object in the same form the last time you left it. Storing user information, for instance.

Basset::Object::Persistent allows you to do that transparently and easily. Persistent objects need to define several pieces of additional
information to allow them to commit to the database, including their table definitions. Once these items are defined, you'll have access
to the load and commit methods to allow you to load and store the objects in a database.

It is assumed that an object is stored in the database in a primary table. The primary table
contains a set of columns named the same as object attributes. The attributes are stored in those columns.

 Some::Package->add_attr('foo');
 my $obj = Some::Package->new();
 $obj->foo('bar');
 $obj->commit();

 in the database, the 'foo' column will be set to 'bar'.

=cut

use Scalar::Util qw(weaken isweak);

use Basset::Object;
our @ISA = Basset::Object->pkg_for_type('object'); 

use strict;
use warnings;

=pod

=head1 ATTRIBUTES

=over

=item loaded

boolean flag 1/0.

This flag tells you whether or not the objects you are operating on has been loaded from a database or initially created
at this time and not loaded. This flag is set internally, and you should only read it.

=cut

=pod

=begin btest(loaded)

my $o = __PACKAGE__->new();
$test->ok($o, "Got object");
$test->is(scalar(__PACKAGE__->loaded), undef, "could not call object method as class method");
$test->is(__PACKAGE__->errcode, "BO-08", "proper error code");
$test->is(scalar($o->loaded), 0, 'loaded is 0');
$test->is($o->loaded('abc'), 'abc', 'set loaded to abc');
$test->is($o->loaded(), 'abc', 'read value of loaded - abc');
my $h = {};
$test->ok($h, 'got hashref');
$test->is($o->loaded($h), $h, 'set loaded to hashref');
$test->is($o->loaded(), $h, 'read value of loaded  - hashref');
my $a = [];
$test->ok($a, 'got arrayref');
$test->is($o->loaded($a), $a, 'set loaded to arrayref');
$test->is($o->loaded(), $a, 'read value of loaded  - arrayref');

=end btest(loaded)

=cut

__PACKAGE__->add_attr('loaded');

=pod

=item loading

read only boolean flag 1/0.

This flag is usually used internally, it keeps track of whether or not the object is currently in the process of loading
from the database. It will always be zero unless the object is loading. This flag is set internally, and you should only read it.

=cut

=pod

lib/Basset/Object/Persistent.pm view on Meta::CPAN

			) or return $self->fatalerror($table->errvals);

			my @values = map {$self->$_()} $table->alias_column($table->update_bindables) or return $self->fatalerror($self->errvals);

			$self->arbitrary_sql(
				'query' => $query,
				'vars'	=> \@values,
				'table'	=> $table,
				'cols'	=> [$table->update_bindables]
			) or return $self->fatalerror($self->errvals);

		}
		#or we're inserting
		else {

			my $insert_query = $table->insert_query or return $self->fatalerror($table->errvals);

			my @values = map {$self->$_()} $table->alias_column($table->insert_bindables) or return $self->fatalerror($self->errvals);

			$self->arbitrary_sql(
				'query' => $insert_query,
				'vars'  => \@values,
				'table' => $table,
				'cols'	=> [$table->insert_bindables]
			) or return $self->fatalerror($self->errvals);

			if ($table->autogenerated){

				my $driver	= $self->driver or return $self->fatalerror($self->errvals);

				my $id_stmt = $driver->prepare_cached($table->last_insert_query())
					or return $self->fatalerror($driver->errstr, "BOP-05");

				$id_stmt->execute()
					or return $self->fatalerror($id_stmt->errstr, "BOP-04");

				my ($id) = $id_stmt->fetchrow_array;

				$id_stmt->finish()
					or return $self->fatalerror($id_stmt->errstr, "BOP-10");

				my $primary	= $table->alias_column($table->primary_column);
				$self->$primary($id);
			};

		};
	}

	#commit our nonsingleton tied relationships
	$self->commit_relationships('nonsingletons') or return $self->fatalerror($self->errvals);

	#we have committed this object
	$self->committed(1);
	#and it's in the database
	$self->in_db(1);

	my $primary_identifier = $self->primary_identifier('string');
	my $load_cache = $self->central_load_cache;
	unless (defined $load_cache->{$primary_identifier}) {
		$load_cache->{$primary_identifier} = $self;
		weaken($load_cache->{$primary_identifier});
	}

	$self->end() or return $self->fatalerror($self->errvals);

	$self->committing(0);

	return $self;

}

=pod

=item writable_method

Given a method name, returns true if the value of this method will be written out to disk on the
next commit, and false if it will not be written out.

 my $output = $object->writable_method('id');
 if ($output) {
 	print "object will store id\n";
 } else {
 	print "object will not store id\n";
 }

=cut

=pod

=begin btest(writable_method)

$test->is(scalar(__PACKAGE__->writable_method), undef, "Cannot determine if writable on a class");
$test->is(__PACKAGE__->errcode, "BOP-62", "proper error code");

my $subclass = "Basset::Test::Testing::__PACKAGE__::writable_method::Subclass1";

package Basset::Test::Testing::__PACKAGE__::writable_method::Subclass1;
our @ISA = qw(__PACKAGE__);

$subclass->add_attr('one');
$subclass->add_attr('two');
$subclass->add_attr('three');

package __PACKAGE__;

my $o = $subclass->new();
$test->ok($o, "Got object");

$test->is(scalar($o->writable_method), undef, "Cannot determine if writable w/o method");
$test->is($o->errcode, "BOP-63", "proper error code");

$test->is(scalar($o->writable_method('one')), undef, "Cannot determine if writable w/o primary table");
$test->is($o->errcode, 'BOP-64', "proper error code");

$subclass->add_primarytable(
	'name' => 'test_table',
	'definition' => {
		'one' => 'SQL_INTEGER',
		'two' => 'SQL_INTEGER',
		'three' => 'SQL_INTEGER',
	},

lib/Basset/Object/Persistent.pm view on Meta::CPAN


	my $tables = $class->tables;	

	my $omit_tables = undef;

	if ($clauses->{'tables'}) {
		$tables = [@{$class->tables}, @{$clauses->{'tables'}}];
		$omit_tables	= $clauses->{'tables'};
		delete $clauses->{'tables'};
	}

	return $class->error("Cannot load with no table", "BOP-01") unless @$tables;

	my $iterated = $clauses->{'iterator'} || 0;
	delete $clauses->{'iterator'};

	my $tableClass = $class->pkg_for_type('table') or return;

	my $multiselect_query = $tableClass->multiselect_query(
		'tables'					=> $tables,
		'omit_columns_from_tables'	=> $omit_tables,
		'use_aliases'				=> 1,
	) or return $class->error($tableClass->errvals);

	my $query	= $tableClass->attach_to_query(
		$multiselect_query,
		$clauses
	) or return $class->error($tableClass->errvals);

	$class->iterator(undef) unless $clauses->{'_loading_next'};

	my $stmt = $class->iterator || $class->arbitrary_sql(
		'query' => $query,
		'vars'	=> \@args,
		'iterator' => 1,
	) or return;

	my @objs = ();

	if ($iterated && ! $class->iterator) {
		$class->iterator($stmt);
		return $stmt;
	}

	my $load_cache = $class->central_load_cache;

	while (my $stuff = $stmt->fetchrow_hashref('NAME_lc')){

		my $obj = $class->new('loading' => 1, 'in_db' => 1, %$stuff, %{$clauses->{'constructor'}}, 'loaded' => 1)
			or return $class->error("Cannot create object : " . $class->error, "BOP-06");
		$obj->loading(0);

		my $primary_identifier = $obj->primary_identifier('string');
		
		if (defined $load_cache->{$primary_identifier}) {
			$obj = $load_cache->{$primary_identifier};
		}
		else {

			$load_cache->{$primary_identifier} = $obj;
			weaken($load_cache->{$primary_identifier});

			$obj->setup() or return $class->error("Setup failed in object : " . $obj->error, $obj->errcode || "BOP-47");
		}

		#no matter what, we nuke our instantiated relationships, they can no longer be trusted.
		$obj->instantiated_relationships({});

		if (my $transform = $clauses->{'transform'}) {
			my $transformed = $obj->$transform();
			return $class->error("Cannot transform object into non-object", "BOP-91")
				unless $obj->is_relationship($transform) && ref $transformed;
			$obj = $transformed;
		};

		push @objs, $obj;

		if ($iterated) {
			return $obj;
		};
	};

	$stmt->finish()
		or return $class->error($stmt->errstr, "BOP-10");

	if ($iterated && ! @objs) {
		$class->iterator(undef);
		return;
	};

	if ($clauses->{'singleton'}) {
		my $return = $objs[0] or return $class->error("Cannot load single object - no objects returned", "BOP-84");
		return $clauses->{'force_arrayref'} ? (\@objs, $return) : $return;
	}
	else {
		my $return;
		if (my $key = $clauses->{'key'}) {
			my %objs = map {$_->$key(), $_} @objs;
			$return = \%objs;
		} else {
			$return = \@objs;
		}
		return $clauses->{'force_arrayref'} ? (\@objs, $return) : $return;
	}

};

=pod

=item exists

Query to quickly determine if a given object (or set of objects) exists in the database. The objects will not be loaded.
Returns a count of the number of objects that exist.

 my $itsthere = Basset::User->exists(1); #user id 1 exists in the database

=cut

=pod

=begin btest(exists)

( run in 1.036 second using v1.01-cache-2.11-cpan-d8267643d1d )