view release on metacpan or  search on metacpan

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

package Class::DBI::Frozen::301;

BEGIN {
  my @cdbi_packages = qw(Column ColumnGrouper Iterator Relationship Query
                        Relationship::HasA Relationship::MightHave
                        Relationship::HasMany);

  my @cdbi_modules = qw(Column ColumnGrouper Iterator Relationship Query
                        Relationship/HasA Relationship/MightHave
                        Relationship/HasMany);
  
  $INC{'Class/DBI.pm'} = 'Set by Class::DBI::Frozen::301';
  $INC{"Class/DBI/${_}.pm"} = 'Set by Class::DBI::Frozen::301'
    for @cdbi_modules;

  eval "use Class::DBI::Frozen::301::$_;" for @cdbi_packages;
}

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

require 5.00502;

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

package Class::DBI;

use strict;

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

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

use Class::DBI::ColumnGrouper;
use Class::DBI::Query;
use Carp ();
use List::Util;
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);
}

{
	my %deprecated = (
		croak            => "_croak",               # 0.89
		carp             => "_carp",                # 0.89
		min              => "minimum_value_of",     # 0.89
		max              => "maximum_value_of",     # 0.89
		normalize_one    => "_normalize_one",       # 0.89
		_primary         => "primary_column",       # 0.90
		primary          => "primary_column",       # 0.89
		primary_key      => "primary_column",       # 0.90
		essential        => "_essential",           # 0.89
		column_type      => "has_a",                # 0.90
		associated_class => "has_a",                # 0.90
		is_column        => "find_column",          # 0.90
		has_column       => "find_column",          # 0.94
		add_hook         => "add_trigger",          # 0.90
		run_sql          => "retrieve_from_sql",    # 0.90
		rollback         => "discard_changes",      # 0.91
		commit           => "update",               # 0.91
		autocommit       => "autoupdate",           # 0.91
		new              => 'create',               # 0.93
		_commit_vals     => '_update_vals',         # 0.91
		_commit_line     => '_update_line',         # 0.91
		make_filter      => 'add_constructor',      # 0.93
	);

	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;
		};
	}
}

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

	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};
}

# keep an index of live objects using weak refs
my %Live_Objects;
my $Init_Count = 0;

sub _init {
	my $class = shift;
	my $data = shift || {};
	my $obj;
	my $obj_key = "";

	my @primary_columns = $class->primary_columns;
	if (@primary_columns == grep defined, @{$data}{@primary_columns}) {

		# create single unique key for this object
		$obj_key = join "|", $class, map { $_ . '=' . $data->{$_} }
			sort @primary_columns;
	}

	unless (defined($obj = $Live_Objects{$obj_key})) {

		# not in the object_index, or we don't have all keys yet
		$obj = bless {}, $class;
		$obj->_attribute_store(%$data);

		# don't store it unless all keys are present
		if ($obj_key && $Weaken_Is_Available) {
			weaken($Live_Objects{$obj_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 purge_dead_from_object_index {
	delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects };
}

sub remove_from_object_index {
	my $self            = shift;
	my @primary_columns = $self->primary_columns;
	my %data;
	@data{@primary_columns} = $self->get(@primary_columns);
	my $obj_key = join "|", ref $self, map $_ . '=' . $data{$_},
		sort @primary_columns;
	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 _create {
	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) {
		($class->has_real_column($col) ? $real : $temp)->{$col} =
			$self->_attrs($col);
	}
	$self->_insert_row($real);

	my @primary_columns = $class->primary_columns;
	$self->_attribute_store(
		$primary_columns[0] => $real->{ $primary_columns[0] })