view release on metacpan or  search on metacpan

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

package Class::DBI::Lite;

use strict;
use warnings 'all';
use base 'Ima::DBI::Contextual';
use Carp qw( cluck confess );
use SQL::Abstract;
use SQL::Abstract::Limit;
use Class::DBI::Lite::Iterator;
use Class::DBI::Lite::Pager;
use Class::DBI::Lite::RootMeta;
use Class::DBI::Lite::EntityMeta;
use Digest::MD5 'md5_hex';
use POSIX 'ceil';
use overload 
  '""'      => sub { eval { $_[0]->id } },
  bool      => sub { eval { $_[0]->id } },
  fallback  => 1;

our $VERSION = '1.034';
our $meta;

our %DBI_OPTIONS = (
  FetchHashKeyName    => 'NAME_lc',
  ShowErrorStatement  => 1,
  ChopBlanks          => 1,
  AutoCommit          => 1,
  RaiseError          => 1,
);

BEGIN {
  use vars qw( $Weaken_Is_Available %Live_Objects );

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


#==============================================================================
# Abstract methods:
sub set_up_table;
sub get_last_insert_id;


#==============================================================================
sub import
{
  my $class = shift;

  no strict 'refs';
  $class->_load_class( ( @{$class.'::ISA'} )[0] );
  if( my $table = eval { ( @{$class.'::ISA'} )[0]->table } )
  {
    $class->set_up_table( $table );
  }# end if()
}# end import()


#==============================================================================
sub clear_object_index
{
  my $s = shift;
  
  my $class = ref($s) ? ref($s) : $s;
  my $key_starter = $s->root_meta->schema . ":" . $class;
  map { delete($Live_Objects{$_}) } grep { m/^$key_starter\:\d+/o } keys(%Live_Objects);
}# end clear_object_index()


#==============================================================================
sub find_column
{
  my ($class, $name) = @_;
  
  my ($col) = grep { $_ eq $name } $class->columns('All')
    or return;
  return $col;
}# end find_column()


#==============================================================================
sub construct
{
  my ($s, $data, $is_void_context) = @_;
  
  my $class = ref($s) ? ref($s) : $s;

  my $PK = $class->primary_column;
  my $key = join ':', grep { defined($_) } ( $s->root_meta->schema, $class, $data->{ $PK } );
  return $Live_Objects{$key} if $Live_Objects{$key};
  
  $data->{__id} = $data->{ $PK };
  $data->{__Changed} = { };
  
  my $obj = bless $data, $class;
  if( $Weaken_Is_Available && ! $is_void_context )
  {
    $Live_Objects{$key} = $obj;
    
    weaken( $Live_Objects{$key} );
    return $Live_Objects{$key};
  }
  else
  {
    return $obj;
  }# end if()
}# end construct()


#==============================================================================
sub deconstruct
{
  my $s = shift;
  
  bless $s, 'Class::DBI::Lite::Object::Has::Been::Deleted';
}# end deconstruct()


#==============================================================================
sub schema { $_[0]->root_meta->schema }
sub dsn    { $_[0]->root_meta->dsn }
sub table  { $_[0]->_meta->{table} }
sub triggers { @{ $_[0]->_meta->{triggers}->{ $_[1] } } }
sub _meta { }
sub set_cache { my ($class, $cache) = @_; $class->_meta->{cache} = $cache }
sub cache { shift->_meta->{cache} }


#==============================================================================
sub _init_meta
{
  my ($class, $entity) = @_;
  
  no strict 'refs';
  no warnings qw( once redefine );
  my $schema = $class->root_meta->schema;
  
  my $_class_meta = Class::DBI::Lite::EntityMeta->new( $class, $schema, $entity );
  
  # If we are re-initializing meta (i.e. changed schema) then remove accessors first:
  foreach my $col ( eval { $class->columns } )
  {
    local $SIG{__WARN__} = sub { };
    *{"$class\::$col"} = undef;
  }# end foreach()
  
  *{"$class\::_meta"} = sub { $_class_meta };
  
  my $pk = ($class->columns('Primary'))[0];
  *{"$class\::primary_column"} = sub { $pk };
  *{"$class\::$pk"} = sub { $_[0]->{$pk} };
  
  # Install the column accessors:
  foreach my $col ( grep { $_ ne $pk } $class->columns )
  {
    my $setter = "_set_$col";
    my $getter = "_get_$col";
    *{"$class\::$setter"} = sub {
      my ($s, $newval) = @_;
        no warnings 'uninitialized';