File Coverage

blib/lib/DBIx/Objects.pm

Criterion	Covered	Total	%
statement	22	223	9.8
branch	0	78	0.0
condition	0	81	0.0
subroutine	8	36	22.2
pod			n/a
total	30	418	7.1

package DBIx::Objects;

use strict;
use warnings qw(all);
use vars qw($VERSION);

BEGIN {
    $VERSION=0.04;
}

###

package DBIx::Object;

use strict;
use warnings qw(all);

# Back-end methods
sub _blank {    # Default back-end for constructor
                # ARGS: $self, [$namespace,] @arglist
                # $namespace - Scalar (string) - Namespace of managing package for variables
                # @arglist   - Array (string) - List of variables to be registered as methods
    my $self=shift;
    my $package=
          (UNIVERSAL::isa($_[0],__PACKAGE__) && # Looks like a descendant
          shift) || caller; # Shift or autodetect namespace to register
    warn "Package $package not listed in registry"
        unless defined($self->{_REGISTRY}{$package});
    while (@_) {
        local $_=uc(shift);
        $self->{$_}=undef;
        $self->{_REGISTRY}{_DATA}{$_}{source}=$package;
        $self->{_REGISTRY}{_DATA}{$_}{access}=1; # default to rw
	$self->{_REGISTRY}{_DATA}{$_}{type}="basic";
    }
}

sub _register { # Default back-end for package registration
                # Call immediately after being bless()ed
    my $self=shift;
    my $package=caller;
    $self->{_REGISTRY}{$package}{prep}=0 unless (defined($self->{_REGISTRY}{$package}));
    return defined($self->{_REGISTRY}{$package});
}

sub _unregister{# Default back-end for package de-registration
                # If you wish to partially destruct an object, make sure to call this
                # from each namespace being removed from the object
    my $self=shift;
    my $package=caller;
    $self->_taint($package);
    undef $self->{_REGISTRY}{$package};
    return (!(defined($self->{_REGISTRY}{$package})));
}

sub _primary {  # Sets/detects whether a namespace contains the primary key
                # Used internally to assure that the primary key's namespace is always
                # in sync with the rest of the object
    my $self=shift;
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || caller;
    if ($_[0]) {$self->{_REGISTRY}{_PRIMARY}=$package;$self->_taint;}
    return ($self->{_REGISTRY}{_PRIMARY} || 0);
}

sub _readonly { # Sets/detects whether a data mehod is tagged read-only
                # Used by AUTOLOAD to detect read-only method calls
    my $self=shift;
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || caller;
    my $var=uc(shift);
    if (@_) {local $_=shift;$self->{_REGISTRY}{_DATA}{$var}{access}=(!($_)?1:0) if (/[01]/);} #Set to "0" to catch in this check next time
    return (!($self->{_REGISTRY}{_DATA}{$var}{access}) ||
            $self->{_REGISTRY}{_DATA}{$var}{source} eq $self->_primary);
}

sub _validate { # Marks a namespace as tied to the back-end database
                # Intended to be called on first refresh - Paired with _taint
    my $self=shift;
    my $package=shift || caller;
    (my @vars=$self->_vars($package)) || return $self;
    foreach my $var (@vars) {
	if ($self->_isobject($var)) { # Reset embedded object information (only if needed)
	    unless ($self->{var} && ($self->{_REGISTRY}{_DATA}{$var}{data} eq $self->{$var})) {
		$self->{_REGISTRY}{_DATA}{$var}{data}=$self->{$var};
		$self->{_REGISTRY}{_DATA}{$var}{prep}=0;
		$self->{$var}=undef;
	    }
	}
    }
    $self->{_REGISTRY}{$package}{prep}=1;
    $self->{_REGISTRY}{ref($self)}{prep}=1;
    $self->_clean($package);
}

sub _taint {    # Marks a namespace as untied from the back-end database
                # Intended to be called on destruction only
    my $self=shift;
    my $package=shift || caller;
    $self->_dirty($package);
    (my @vars=$self->_vars($package)) || return $self;
    foreach my $var (@vars) {
	if ($self->_isobject($var)) { # Reset embedded object information (only if needed)
	    $self->{_REGISTRY}{_DATA}{$var}{prep}=0;
	    $self->{$var}=undef;
	}
    }
    $self->{_REGISTRY}{$package}{prep}=0;
}

sub _clean {    # Marks a namespace as in-sync with the back-end database
                # Intended to be called on all calls to add(), refresh() and update()
    my $self=shift;
    my $package=shift || caller;
    $self->{_REGISTRY}{$package}{dirty}=0;
}

sub _dirty {    # Marks a namespace as out-of-sync with the back-end databse
                # Intended to be called upon a write-access call to a class-method
    my $self=shift;
    my $package=shift || caller;
    $self->{_REGISTRY}{$package}{dirty}=1;
}

sub _vars {     # Returns a list of variables registered to a specific namespace
                # Used internally by default _refresh() and update() methods
    my $self=shift;
    my $package=shift || caller;
    my @vars = ();
    my @keys = keys(%{$self->{_REGISTRY}{_DATA}});
    foreach my $var(@keys) {
        push @vars,$var if ($self->{_REGISTRY}{_DATA}{$var}{source} eq $package);
    }
    return @vars;
}

sub _refresh {  # Default back-end for refresh
                # Inherited classes should implement a custom _refresh()
                # Alternatively, the default _refresh may be used if a valid DBI connection
                # is set using $__PACKAGE__::dbh and the table is set to $__PACKAGE__::table
    my $self=shift;
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || ref($self);
    my @vars=$self->_vars($package) || return $self;
    my $sth;
    {
        no strict 'vars';
        eval "\$sth=\$dbh->prepare_cached('SELECT \@vars FROM \$table WHERE (ID=?)');";
    }
    $sth->execute(@_) or return $self->blank;
    if ($sth->rows!=1) {
	$self->blank;
    } else {
	my $res=$sth->fetchrow_hashref;
	foreach my $var (@vars) {
	    $self->{$var}=$res->{$var};
	}
        $self->_validate;
    }
    $sth->finish;
    return $self;
}

sub AUTOLOAD {  # Default method call handler
                # Current support:
                #    * Read/Write registered methods from internal hash
    my $param;
    my $package;
    {
        no strict 'vars';
        $AUTOLOAD=~s/(.*):://;
	$package=$1;
        $param=$AUTOLOAD;
    }
    if (UNIVERSAL::isa($_[0],__PACKAGE__)) { # Method call of a sub-class
        my $self=shift;
        if ($self->{_REGISTRY}{_DATA}{uc($param)}) { # Acceptable function call
            my $source=$self->{_REGISTRY}{_DATA}{uc($param)}{source};
            if (!($self->valid($source))) {
                $self->refresh($source);
            }
	    # SET access
            if ((@_) && !($self->_readonly($source,$param))) { # Update rewriteable request
		if ($self->_isbasic($param)) {
		    $self->{uc($param)}=@_;
		    $self->_taint;
		} elsif ($self->_isobject($param)) { # Object SET
		    unless ($self->_isobjarray($param)) { # No SET allowed on arrays
			my ($temp,$pid)=@_;
			if (ref($temp) eq $self->{_REGISTRY}{_DATA}{uc($param)}{class}) {
			    # TODO: see if temp->isa($self->{_REGISTRY}{_DATA}{uc($param)}{class})
			    $pid=$temp->id; #Retrieve ID from internal object
			} else {
			    $pid=$temp; #Assume ID is specified if not compatible object
			}
			$self->{_REGISTRY}{_DATA}{uc($param)}{data}=$pid;
			$self->_taint;
		    }
		}
            } # GET access
	    if ($self->_isobject($param)) { # Prepare object
		return (wantarray?undef:0) unless $self->_o_prep($param);
	    }
	    if ($self->_isobjarray($param)) { # Object array returns special values
		    return (wantarray?@{$self->{uc($param)}}:$self->{_REGISTRY}{_DATA}{uc($param)}{prep});
	    } else {
		return $self->{uc($param)};
	    }
        }
    }
}

sub new {       # Default constructor
                # Do not overload this unless you're SURE you know what you're doing
    my $self={ };
    my $proto=shift;
    my $class=ref($proto) || $proto;
    bless $self,$class;
    eval "foreach \$_ (\@".$class."::ISA) {eval \$_.\"::blank(\\\$self);\";}";
    $self->_register;
    $self->blank(@_);
    if (@_) {
        eval ($self->_primary."::_refresh(\$self,'".$self->_primary."',@_);") if ($self->_primary);
	$self->_refresh(@_);
    }
    return $self;
}

sub clean {     # Returns true if namepace is in-sync with back-end database
                # Be sure to check for valid()ity BEFORE using this
    my $self=shift;
    my $package=shift || caller;
    return !($self->{_REGISTRY}{$package}{dirty});
}

sub valid {     # Returns true if namespace is tied and in-sync with back-end database
    my $self=shift;
    my $package=shift || ref($self);
    if ($self->_primary)
    {return ($self->{_REGISTRY}{$self->_primary}{prep} &&
             $self->clean($self->_primary) &&
             $self->{_REGISTRY}{$package}{prep} &&
             $self->clean($package))}
    else {return $self->{_REGISTRY}{$package}{prep} &&
                 $self->clean($package)};
}

sub blank {     # Default (abstract) blank method - used by the default constructor
                # This should be overridden by any inherited class that's meant to be useful
                # A typical blank() method should look like:
                #    sub blank {
                #        my $self=shift;
                #        $self->_register;
                #        $self->_blank("FOO", "BAR", ... , "LAST");
                #    }
    $_[0]->_register;
}

sub refresh {   # Default front-end for refresh
    my $self=shift;
    my $package=shift || ref($self);
    $self->_taint($package);
    eval $package."::_refresh(\$self,".$self->id.");";
    return $self->valid;
}

sub id  {      # Default id method - must be explicitly so that it can be overloaded
	       # when needed for refresh, but not be dependant on the object being valid
    my $self=shift;
    # Set access
    if ((@_) && !($self->_readonly("id"))) { # Update rewriteable request
	$self->{ID}=@_;
        $self->_taint;
    }
    return $self->{ID};
}

sub _isbasic { # Returns true if access method marked as basic (default)
    my $self=shift;
    my $var=uc(shift);
    return ($self->{_REGISTRY}{_DATA}{$var}{type} eq "basic");
}

sub _isobject { # Returns true if access method marked as embedded object
    my $self=shift;
    my $var=uc(shift);
    return ($self->{_REGISTRY}{_DATA}{$var}{type} eq "object");
}

sub _isobjarray {
    my $self=shift;
    my $var=uc(shift);
    return ($self->_isobject($var) && $self->{_REGISTRY}{_DATA}{$var}{array});
}

sub _object { # Marks an access member as an object (call in blank)
    my $self=shift;
    my $var=uc(shift);
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || ref($self);
    $self->{_REGISTRY}{_DATA}{$var}{prep}=0;
    $self->{_REGISTRY}{_DATA}{$var}{class}=$package;
    $self->{_REGISTRY}{_DATA}{$var}{data}=$self->{$var} || undef;
    $self->{_REGISTRY}{_DATA}{$var}{array}=0;
    $self->{_REGISTRY}{_DATA}{$var}{type}="object";
    $self->{$var}=undef;
}

sub _objarray { # Marks an access member as an array of objects (call in blank)
    my $self=shift;
    my $var=uc(shift);
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || ref($self);
    $self->_object($var,$package);
    $self->_readonly($var,1);
    $self->{_REGISTRY}{_DATA}{$var}{array}=1;
}

# This (objarray) won't be fully implemented until I can figure out how the heck
# to set the data source as an array - it probably has to be dealt with by
# end-module's refresh ($self->{$var}=@arrayofdata;) [UPDATE VALIDATE TO DEAL WITH THIS]...

sub _o_prep {
    my $self=shift;
    my $var=uc(shift);
    my $class=$self->{_REGISTRY}{_DATA}{$var}{class};
    my $source=$self->{_REGISTRY}{_DATA}{$var}{source};
    return 0 unless $self->valid($source);
    return $self->{_REGISTRY}{_DATA}{$var}{prep} if
	$self->{_REGISTRY}{_DATA}{$var}{prep};
    if ($self->_isobjarray($var)) {
	for (my $i=0;$i<=$#{$self->{_REGISTRY}{_DATA}{$var}{data}};$i++) {
	    $self->{$var}[$i]=$class->new($self->{_REGISTRY}{_DATA}{$var}{data}[$i]);
	}
	$self->{_REGISTRY}{_DATA}{$var}{prep}=$#{$self->{_REGISTRY}{_DATA}{$var}{data}}+1;
    } else {
	$self->{_REGISTRY}{_DATA}{$var}{prep}=(($self->{$var}=$class->new($self->{_REGISTRY}{_DATA}{$var}{data}))?1:0);
    }
    return $self->{_REGISTRY}{_DATA}{$var}{prep};
}

# TODO: Update updates recursively (into embedded objects)
#        UpdateNR updates non-0recursively (data ghets lost)

# DOCUMENT: _validate also initializes objects by setting internal DATA value and clearing external value


package DBIx::Object::DBI; #Shortcut functions for DBI-based backend

our @ISA=qw(DBIx::Object);

sub blank {
    $_[0]->_register;
}

sub _dbidbh {		# Sets/returns the DBI connection to use
    my $self=shift;
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || caller;
    if($_[0]) {$self->{_REGISTRY}{$package}{DBI}{dbh}=$_[0];}
    return $self->{_REGISTRY}{$package}{DBI}{dbh};
}

sub _dbirefresh {	# Sets/returns the SQL statement to run on refresh calls
    my $self=shift;
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || caller;
    if($_[0]) {$self->{_REGISTRY}{$package}{DBI}{refresh}=$_[0];}
    return $self->{_REGISTRY}{$package}{DBI}{refresh};
}

sub _refresh {   # Default back-end for DBI refresh
                 # Inherited classes may implement a custom _refresh()
    my $self=shift;
    my $package=(UNIVERSAL::isa($_[0],__PACKAGE__) && shift) || ref($self);
    my $sth=$self->{_REGISTRY}{$package}{DBI}{dbh}->prepare_cached($self->{_REGISTRY}{$package}{DBI}{refresh});
        $sth->execute(@_) or return $self->blank;
    if ($sth->rows!=1) {
	$self->blank;
    } else {
	my $res=$sth->fetchrow_hashref;
        foreach my $key (keys %{$res}) {
            $self->{uc($key)}=$res->{$key};
        }
        $self->_validate($package);
    }
    $sth->finish;
    return $self;
}

1;

__END__