weaken results from the CPAN

Class-DBI

package Class::DBI::__::Base;

require 5.006;

use Class::Trigger 0.07;
use base qw(Class::Accessor Class::Data::Inheritable Ima::DBI);

package Class::DBI;

use version; $VERSION = qv('3.0.17');

use strict;
use warnings;

use base "Class::DBI::__::Base";

use Class::DBI::ColumnGrouper;
use Class::DBI::Query;
use Carp ();
use List::Util;
use Clone ();
use UNIVERSAL::moniker;

use vars qw($Weaken_Is_Available);

BEGIN {
	$Weaken_Is_Available = 1;
	eval {
		require Scalar::Util;
		import Scalar::Util qw(weaken);
	};
	if ($@) {
		$Weaken_Is_Available = 0;
	}
}

use overload
	'""'     => sub { shift->stringify_self },
	bool     => sub { not shift->_undefined_primary },
	fallback => 1;

sub stringify_self {
	my $self = shift;
	return (ref $self || $self) unless $self;    # empty PK
	my @cols = $self->columns('Stringify');
	@cols = $self->primary_columns unless @cols;
	return join "/", $self->get(@cols);
}

sub _undefined_primary {
	my $self = shift;
	return grep !defined, $self->_attrs($self->primary_columns);
}

#----------------------------------------------------------------------
# Deprecations
#----------------------------------------------------------------------

__PACKAGE__->mk_classdata('__hasa_rels' => {});

{
	my %deprecated = (
   # accessor_name => 'accessor_name_for', # 3.0.7
   # mutator_name  => 'accessor_name_for', # 3.0.7
  );

	no strict 'refs';
	while (my ($old, $new) = each %deprecated) {
		*$old = sub {
			my @caller = caller;
			warn
				"Use of '$old' is deprecated at $caller[1] line $caller[2]. Use '$new' instead\n";
			goto &$new;
		};
	}
}

#----------------------------------------------------------------------
# Our Class Data
#----------------------------------------------------------------------
__PACKAGE__->mk_classdata('__AutoCommit');
__PACKAGE__->mk_classdata('__hasa_list');
__PACKAGE__->mk_classdata('_table');
__PACKAGE__->mk_classdata('_table_alias');
__PACKAGE__->mk_classdata('sequence');
__PACKAGE__->mk_classdata('__grouper'   => Class::DBI::ColumnGrouper->new());
__PACKAGE__->mk_classdata('__data_type' => {});
__PACKAGE__->mk_classdata('__driver');
__PACKAGE__->mk_classdata('iterator_class' => 'Class::DBI::Iterator');
__PACKAGE__->mk_classdata('purge_object_index_every' => 1000);

lib/Class/DBI.pm view on Meta::CPAN

#----------------------------------------------------------------------
# Low Level Data Access
#----------------------------------------------------------------------

sub _attrs {
	my ($self, @atts) = @_;
	return @{$self}{@atts};
}
*_attr = \&_attrs;

sub _attribute_store {
	my $self   = shift;
	my $vals   = @_ == 1 ? shift: {@_};
	my (@cols) = keys %$vals;
	@{$self}{@cols} = @{$vals}{@cols};
}

# If you override this method, you must use the same mechanism to log changes
# for future updates, as other parts of Class::DBI depend on it.
sub _attribute_set {
	my $self = shift;
	my $vals = @_ == 1 ? shift: {@_};

	# We increment instead of setting to 1 because it might be useful to
	# someone to know how many times a value has changed between updates.
	for my $col (keys %$vals) { $self->{__Changed}{$col}++; }
	$self->_attribute_store($vals);
}

sub _attribute_delete {
	my ($self, @attributes) = @_;
	delete @{$self}{@attributes};
}

sub _attribute_exists {
	my ($self, $attribute) = @_;
	exists $self->{$attribute};
}

#----------------------------------------------------------------------
# Live Object Index (using weak refs if available)
#----------------------------------------------------------------------

my %Live_Objects;
my $Init_Count = 0;

sub _init {
	my $class = shift;
	my $data  = shift || {};
	my $key   = $class->_live_object_key($data);
	return $Live_Objects{$key} || $class->_fresh_init($key => $data);
}

sub _fresh_init {
	my ($class, $key, $data) = @_;
	my $obj = bless {}, $class;
	$obj->_attribute_store(%$data);

	# don't store it unless all keys are present
	if ($key && $Weaken_Is_Available) {
		weaken($Live_Objects{$key} = $obj);

		# time to clean up your room?
		$class->purge_dead_from_object_index
			if ++$Init_Count % $class->purge_object_index_every == 0;
	}
	return $obj;
}

sub _live_object_key {
	my ($me, $data) = @_;
	my $class   = ref($me) || $me;
	my @primary = $class->primary_columns;

	# no key unless all PK columns are defined
	return "" unless @primary == grep defined $data->{$_}, @primary;

	# create single unique key for this object
	return join "\030", $class, map $_ . "\032" . $data->{$_}, sort @primary;
}

sub purge_dead_from_object_index {
	delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects };
}

sub remove_from_object_index {
	my $self    = shift;
	my $obj_key = $self->_live_object_key({ $self->_as_hash });
	delete $Live_Objects{$obj_key};
}

sub clear_object_index {
	%Live_Objects = ();
}

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

sub _prepopulate_id {
	my $self            = shift;
	my @primary_columns = $self->primary_columns;
	return $self->_croak(
		sprintf "Can't create %s object with null primary key columns (%s)",
		ref $self, $self->_undefined_primary)
		if @primary_columns > 1;
	$self->_attribute_store($primary_columns[0] => $self->_next_in_sequence)
		if $self->sequence;
}

sub _insert {
	my ($proto, $data) = @_;
	my $class = ref $proto || $proto;

	my $self = $class->_init($data);
	$self->call_trigger('before_create');
	$self->call_trigger('deflate_for_create');

	$self->_prepopulate_id if $self->_undefined_primary;

	# Reinstate data
	my ($real, $temp) = ({}, {});
	foreach my $col (grep $self->_attribute_exists($_), $self->all_columns) {

lib/Class/DBI.pm view on Meta::CPAN

These are thin aliases through to the DBI's commit() and rollback()
commands to commit or rollback all changes to this object.

=head2 Localised Transactions

A nice idiom for turning on a transaction locally (with AutoCommit turned
on globally) (courtesy of Dominic Mitchell) is:

  sub do_transaction {
    my $class = shift;
    my ( $code ) = @_;
    # Turn off AutoCommit for this scope.
    # A commit will occur at the exit of this block automatically,
    # when the local AutoCommit goes out of scope.
    local $class->db_Main->{ AutoCommit };

    # Execute the required code inside the transaction.
    eval { $code->() };
    if ( $@ ) {
      my $commit_error = $@;
      eval { $class->dbi_rollback }; # might also die!
      die $commit_error;
    }
  }

  And then you just call:

  Music::DBI->do_transaction( sub {
    my $artist = Music::Artist->insert({ name => 'Pink Floyd' });
    my $cd = $artist->add_to_cds({ 
      title => 'Dark Side Of The Moon', 
      year => 1974,
    });
  });

Now either both will get added, or the entire transaction will be
rolled back.

=head1 UNIQUENESS OF OBJECTS IN MEMORY

Class::DBI supports uniqueness of objects in memory. In a given perl
interpreter there will only be one instance of any given object at
one time. Many variables may reference that object, but there can be
only one.

Here's an example to illustrate:

  my $artist1 = Music::Artist->insert({ artistid => 7, name => 'Polysics' });
  my $artist2 = Music::Artist->retrieve(7);
  my $artist3 = Music::Artist->search( name => 'Polysics' )->first;

Now $artist1, $artist2, and $artist3 all point to the same object. If you
update a property on one of them, all of them will reflect the update.

This is implemented using a simple object lookup index for all live
objects in memory. It is not a traditional cache - when your objects
go out of scope, they will be destroyed normally, and a future retrieve
will instantiate an entirely new object.

The ability to perform this magic for you replies on your perl having
access to the Scalar::Util::weaken function. Although this is part of
the core perl distribution, some vendors do not compile support for it.
To find out if your perl has support for it, you can run this on the
command line:

  perl -e 'use Scalar::Util qw(weaken)'

If you get an error message about weak references not being implemented,
Class::DBI will not maintain this lookup index, but give you a separate
instances for each retrieve.

A few new tools are offered for adjusting the behavior of the object
index. These are still somewhat experimental and may change in a
future release.

=head2 remove_from_object_index

  $artist->remove_from_object_index();

This is an object method for removing a single object from the live
objects index. You can use this if you want to have multiple distinct
copies of the same object in memory.

=head2 clear_object_index

  Music::DBI->clear_object_index();

You can call this method on any class or instance of Class::DBI, but
the effect is universal: it removes all objects from the index.

=head2 purge_object_index_every

  Music::Artist->purge_object_index_every(2000);

Weak references are not removed from the index when an object goes
out of scope. This means that over time the index will grow in memory.
This is really only an issue for long-running environments like mod_perl,
but every so often dead references are cleaned out to prevent this. By
default, this happens every 1000 object loads, but you can change that
default for your class by setting the 'purge_object_index_every' value.

(Eventually this may handled in the DESTROY method instead.)

As a final note, keep in mind that you can still have multiple distinct
copies of an object in memory if you have multiple perl interpreters
running. CGI, mod_perl, and many other common usage situations run
multiple interpreters, meaning that each one of them may have an instance
of an object representing the same data. However, this is no worse
than it was before, and is entirely normal for database applications in
multi-process environments.

=head1 SUBCLASSING

The preferred method of interacting with Class::DBI is for you to write
a subclass for your database connection, with each table-class inheriting
in turn from it. 

As well as encapsulating the connection information in one place,
this also allows you to override default behaviour or add additional
functionality across all of your classes.

As the innards of Class::DBI are still in flux, you must exercise extreme
caution in overriding private methods of Class::DBI (those starting with
an underscore), unless they are explicitly mentioned in this documentation
as being safe to override. If you find yourself needing to do this,
then I would suggest that you ask on the mailing list about it, and

( run in 1.566 second using v1.01-cache-2.11-cpan-39bf76dae61 )