package PROP::Object;

use strict;
no strict "refs";
use vars qw/$AUTOLOAD/;
use UNIVERSAL qw/isa/;

use DBI;
use Hash::Util qw/lock_hash lock_keys/;
use Data::Dumper;

use PROP::Schema;
use PROP::SQL::Insert;
use PROP::SQL::Update;
use PROP::SQL::Select;
use PROP::SQL::Delete;
use PROP::Constants;
use PROP::ResultSet::Link;
use PROP::ResultSet::Object;
use PROP::Conf;
use PROP::Exception;
use PROP::Exception::IllegalArgument;
use PROP::Exception::Configuration;

use PROP::Object::MySQL;

my %schemas = ();
my %verifiers = ();

sub new {
    my ($invocant, $specifier) = @_;
    my $class = ref($invocant) || $invocant;
    my $self = bless({}, $class);
    
    my $ISA = $class . '::ISA';
    for(my $i = 0; $i < scalar(@$ISA); ++$i) {
	if($ISA->[$i] eq 'PROP::Object') {
	    $ISA->[$i] = 'PROP::Object::' . get_rdbms();
	}
    }

    $self->{-field_values} = { map { ($_, undef) } $self->get_field_names() };
    $self->{-contextual_values} = {};
    $self->{-modified_fields} = {};
    $self->{-parents} = {};
    $self->{-children} = {};
    $self->{-verifiers} = {};

    lock_hash(%$self) if DEBUG;
    lock_keys(%{$self->{-field_values}}) if DEBUG;

    if($specifier) {
	if(ref($specifier) eq 'HASH') {
	    foreach (keys(%$specifier)) {
		$self->{-field_values}{$_} = $specifier->{$_};
		$self->{-modified_fields}{$_} = 1;
	    }
	}
	elsif($specifier =~ m/^\d+$/) {
	    $self->{-field_values}{$self->get_schema()->get_pk_name()} = $specifier;
	}
	else {
	    die new PROP::Exception::IllegalArgument("invalid object specifier");
	}

	$self->load();
    }

   return $self;
}

sub add_field_verifier {
    my ($invocant, $field, $verifier) = @_;

    die new PROP::Exception::IllegalArgument('invalid invocant')
	if(ref($invocant) and not isa($invocant, 'PROP::Object'));

    die new PROP::Exception::IllegalArgument("unknown field '$field' specified")
	unless($invocant->get_schema()->has_field($field));

    die new PROP::Exception::IllegalArgument("verifier must be a code reference")
	unless(ref($verifier) eq 'CODE');

    if(ref($invocant)) {
	push(@{$invocant->{-verifiers}{$field}}, $verifier);
    }
    else {
	push(@{$verifiers{$field}}, $verifier);
    }
}

sub save {
    my ($self) = @_;

    my @modified_fields = keys(%{$self->{-modified_fields}});

    return unless @modified_fields;

    if($self->get_pk_value() and not $self->{-modified_fields}{$self->get_pk_name()}) {
	my $stmt = new PROP::SQL::Update;
	$stmt->add_table($self->get_table_name());
	$stmt->push_field($_) foreach (@modified_fields);
	$stmt->push_conditional_expression($self->get_pk_name() . ' = ?');

	eval {
	    my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify());
	    $sth->execute((map { $self->get_field_value($_) } @modified_fields),
			  $self->get_pk_value());
	};
	if($@) {
	    my $class = ref($self);
	    my $pk = $self->get_pk_value();
	    die new PROP::Exception("update for $class with primary key $pk failed: $@");
	}
    }
    else {
	my $stmt = new PROP::SQL::Insert;
	$stmt->add_table($self->get_table_name());
	$stmt->push_field($_) foreach (@modified_fields);

	my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify());

	unless($sth->execute(map { $self->get_field_value($_) } @modified_fields)) {
	    my $class = ref($self);
	    die new PROP::Exception("insert for class $class failed");
	}

	if(not $self->{-modified_fields}{$self->get_pk_name()}) {
	    $self->{-field_values}{$self->get_schema()->get_pk_name()} =
		$self->extract_insert_id($sth);
	}
    }

    $self->_clear_modification_flags();
    return $self->get_pk_value();
}

sub load_relatives {
    my ($self, $link_queries) = @_;

    unless(ref($link_queries) eq 'ARRAY' and
	   not grep { not ref($_) eq 'PROP::Query::Link' } @$link_queries)
    {
	my $msg = 'was expecting a reference to an array of PROP::Query::Link objects';
	die new PROP::Exception::IllegalArgument($msg);
    }

    foreach my $lq (@$link_queries) {
	$lq->push_binding($self->get_pk_value());

	if($lq->get_relationship() eq 'parents') {
	    $lq->push_conditional_expression('c.' . $self->get_pk_name() . ' = ?');
	    my $result_set = new PROP::ResultSet::Link($lq);

	    while(my $result = $result_set->get_next_result()) {
		foreach my $parent (@{$result->get_relatives()}) {
		    $self->_add_parent($lq->get_link()->get_table_name(), $parent);
		}
	    }
	}
	elsif($lq->get_relationship() eq 'children') {
	    $lq->push_conditional_expression('p.' . $self->get_pk_name() . ' = ?');
	    my $result_set = new PROP::ResultSet::Link($lq);

	    while(my $result = $result_set->get_next_result()) {
		foreach my $child (@{$result->get_relatives()}) {
		    $self->_add_child($lq->get_link(), $child);
		}
	    }
	}
	else {
	    my $msg = "unexpected relationship type '" . $lq->get_relationship() .
		"' for link " . $lq->get_link()->get_table_name();;
	    die new PROP::Exception($msg);
	}
    }
}

# get the name of the table associated with the derived class
# (the derived class should provide this method)
sub get_table_name {
    my ($invocant) = @_;
    my $class = ref($invocant) || $invocant;
    my $msg = "class '$class' did not define a get_table_name method";
    die new PROP::Exception::Configuration($msg);
}

# get the PROP::Schema object associated with this class
sub get_schema {
    my ($invocant) = @_;
    my $class = ref($invocant) || $invocant;

    $schemas{$class} = new PROP::Schema($class->get_table_name())
	unless $schemas{$class};

    return $schemas{$class};
}

# get the name of the primary key for the derived class
sub get_pk_name {
    my ($self) = @_;
    return $self->get_schema()->get_pk_name();
}

# get the names of the fields of the table associated with the derived
# class, in the order that they appear as columns in the table
sub get_field_names {
    my ($self) = @_;
    return $self->get_schema()->get_field_names();
}

# get the value of the primary key for this object
sub get_pk_value {
    my ($self) = @_;
    return $self->{-field_values}{$self->get_pk_name()};
}

# called by user of API, in the rare case of wanting to set a pk
# directly instead of letting the underlying database auto-increment one
sub set_pk_value {
    my ($self, $value) = @_;

    unless($value =~ /d+/) {
	my $msg = "primary key must be an integer (value '$value' is unacceptable)";
	die new PROP::Exception::IllegalArgument($msg);
    }

    $self->{-field_values}{$self->get_pk_name()} = $value;
    $self->{-modified_fields}{$self->get_pk_name()} = 1;
}

# get a particular field value
sub get_field_value {
    my ($self, $field) = @_;

    if(DEBUG and not $self->get_schema()->has_field($field)) {
	my $msg = ref($self) . " has no field named '$field'";
	die new PROP::Exception::IllegalArgument($msg);
    }

    return $self->{-field_values}{$field};
}

# set a particular field to some new value
sub set_field_value {
    my ($self, $field, $value) = @_;

    if(DEBUG and not $self->get_schema()->has_field($field)) {
	my $msg = ref($self) . " has no field named '$field'";
	die new PROP::Exception::IllegalArgument($msg);
    }

    unless($self->verify_field_value($field, $value)) {
	my $msg = "invalid value '$value' specified for field '" .
	    $field . "' for class " . ref($self);
	die new PROP::Exception::IllegalArgument($msg);
    }

    $self->{-field_values}{$field} = $value;
    $self->{-modified_fields}{$field} = 1;
}

sub verify_field_value {
    my ($self, $field, $value) = @_;

    foreach (@{$verifiers{$field}}, @{$self->{-verifiers}{$field}}) {
	return 0 unless &$_($value);
    }

    return 1;
}

sub _add_parent {
    my ($self, $link, $parent) = @_;

    unless(ref($link) eq 'PROP::Link') {
	my $msg = "first argument should have been a PROP::Link object";
	die new PROP::Exception::IllegalArgument($msg);
    }

    unless(ref($parent) eq $link->get_parent_class()) {
	my $msg = "trying to add a parent of class '" . ref($parent) .
	    "' when class '" . $link->get_parent_class() . "' is expected";
	die new PROP::Exception::IllegalArgument($msg);
    }

    push(@{$self->{-parents}{$link->get_table_name()}}, $parent);
}

sub get_parents {
    my ($self, $link_table_name) = @_;
    my $parents = $self->{-parents}{$link_table_name};
    return () unless $parents;
    return @$parents;
}

sub _add_child {
    my ($self, $link, $child) = @_;

    unless(ref($link) eq 'PROP::Link') {
	my $msg = "first argument should have been a PROP::Link object";
	die new PROP::Exception::IllegalArgument($msg);
    }

    unless(ref($child) eq $link->get_child_class()) {
	my $msg = "trying to add a child of class '" . ref($child) .
	    "' when class '" . $link->get_child_class() . "' is expected";
	die new PROP::Exception::IllegalArgument($msg);
    }

    push(@{$self->{-children}{$link->get_table_name()}}, $child);
}

sub get_children {
    my ($self, $link_table_name) = @_;
    my $children = $self->{-children}{$link_table_name};
    return () unless $children;
    return @$children;
}

# load an object from the database into a memory representation
sub load {
    my ($self) = @_;
    my @field_names = $self->get_field_names();

    my $stmt = new PROP::SQL::Select;
    $stmt->push_field($_) foreach (@field_names);
    $stmt->add_table($self->get_schema()->get_table_name());

    my @values;

    foreach my $field (grep { $self->{-field_values}{$_} } keys(%{$self->{-field_values}})) {
	$stmt->push_conditional_expression($field . ' = ?');	
	push(@values, $self->get_field_value($field));
    }

    my $sth = PROP::DBH::get_handle()->prepare($stmt->stringify());
    $sth->execute(@values);
    my @row = $sth->fetchrow_array();

    unless(@row) {
	if($self->get_pk_value()) {
	    my $err_msg = 'could not query ' . ref($self) .
		' with pk=' . $self->get_pk_value();

	    die new PROP::Exception($err_msg);
	}
	else {
	    return;
	}
    }

    $self->{-field_values}{$_} = shift(@row) foreach (@field_names);

    @row = $sth->fetchrow_array();

    die new PROP::Exception('object was not specified uniquely') if @row;

    $self->_clear_modification_flags();
}

sub _clear_modification_flags {
    my ($self) = @_;

    foreach (keys(%{$self->{-modified_fields}})) {
	delete $self->{-modified_fields}{$_};
    }
}

# for a memory representation of an object, remove its stored
# representation in the database
sub delete {
    my ($self) = @_;

    die new PROP::Exception("delete method invoked when primary key is unset")
	unless $self->get_pk_value();

    my $stmt = new PROP::SQL::Delete;
    $stmt->add_table($self->get_table_name());
    $stmt->push_conditional_expression($self->get_pk_name() . ' = ?');

    eval {
	my $sth = PROP::DBH->get_handle()->prepare($stmt->stringify());
	$sth->execute($self->get_pk_value());
    };
    if($@) {
	my $class = ref($self);
	my $pk = $self->get_pk_value();
	die new PROP::Exception("deletion for $class with primary key $pk failed: $@");
    }
}

sub get_contextual_value {
    my ($self, $field) = @_;
    return $self->{-contextual_values}{$field};
}

sub _set_contextual_value {
    my ($self, $field, $value) = @_;
    $self->{-contextual_values}{$field} = $value;
}

sub has_field {
    my ($invocant, $field) = @_;
    my $class = ref($invocant) || $invocant;
    return $schemas{$class}->has_field($field) ? 1 : 0;
}

# autoload get and set methods for object attributes
sub AUTOLOAD {
    my $sub = $AUTOLOAD;

    if($sub =~ /(.*)::(get|set)_(.*)/) {
	my ($class, $type, $field) = ($1, $2, $3);

	my $table = $schemas{$class};

	if($table and $table->has_field($field)) {
	    if($type eq 'get') {
		*$sub =
		    sub {
			my ($self) = @_;
			return $self->get_field_value($field);
		    }
	    }
	    else {
		*$sub =
		    sub {
			my ($self, $value) = @_;
			return $self->set_field_value($field, $value);
		    }
	    }

	    goto &$sub;
	}
    }

    die "can't autoload $sub" unless($sub =~ /::DESTROY$/);
}

1;

=head1 NAME

PROP::Object

=head1 Description

This class is an abstraction of objects that are stored in the rows of
database tables.  It supports the ability to load single objects, as
specified by a set of conditions, as well as to modify and delete
them, and to load relatives of an object into memory as well.

This class is not intended to be used directly.  Rather, it should be
subclassed, and the derived class should provide a get_table_name()
method which simply returns the name of the table in the database that
corresponds to the type of object being embodied by the subclass.

=head1 Methods

=over

=item new

 $obj = new Foo()
 $obj = new Foo($specifier)

This method creates an instance of object Foo, a derived class of
PROP::Object, possibly loading its contents from the database if
$specifier is passed to new.  The variable $specifier is optional,
depending on your intent, and can either be an integer that specifies
a primary key, or it can be a hash reference that specifies a mapping
of field values.  If $specifier is a primary key and lookup from the
database fails, then an exception will be thrown.  If specifier is a
hash reference and lookup fails, then this may be ascertained by
subsequently calling the get_pk_value() method which will return an
undefined value.  If specifier matches more than one object, then an
exception will be thrown.

=item get_pk_name

 $obj->get_pk_name()

This method returns the name of the primary key for the class of this
object.

=item get_field_names

 $obj->get_field_names()

This method returns the list of field names for the class of this
object, in the order that they appear in the underlying table.

=item has_field

 $obj->has_field($field_name);

This method returns a boolean value indicating whether this object has
a field by the name of $field_name.

=item get_pk_value 

 $obj->get_pk_value()

This method returns the value of the primary key for this instance of
the class.

=item set_pk_value

 $obj->set_pk_value()

This method sets the value of the primary key for this instance of the
class.  You will almost never want to do this.  Usually the primary
key value is set via an automatic incrementation mechanism in the
underlying database.  The only time that this makes sense is if you
are importing data from another database and you want to preserve
keying information.

=item get_field_value

 $obj->get_field_value($field)

This method returns the value of the field named $field.

=item set_field_value

 $obj->set_field_value($field, $value)

This method sets the value of the field named $field to $value.  Note
that this does not result in an immediate update to the object's
representation in the underlying database.  For that to happen, you
must invoke the save() method.

=item get_contextual_value

 $obj->get_contextual_value($field)

This method gets the value of the contextual field $field.  Contextual
values are assigned to objects that are loaded via a link as either a
parent or child of some other object.

=item add_field_verifier

 $class->add_field_verifier($field, $verifier);
 $obj->add_field_verifier($field, $verifier);

This method may be invoked either with a class name or an object
reference.  The first argument is a name of a field, and the second is
a code reference for a subroutine that takes a single argument and
returns a boolean value.  The code reference will be used as a
call-back function, invoked every time the set_field_value method is
invoked.  Namely, set_field_value will pass the value that was passed
to it into the code reference and check the return value, throwing an
exception if execution of the code reference returns false, and
allowing execution to continue if execution of the code reference
returns true.  This allows for an elegant way to automate parameter
validation, and you may add as many verifiers as you like.  If any of
the verifiers return a false value, then despite what the other
verifiers return, verification fails (failure of a verifier causes
short-circuiting of the verification process).

An important thing to note is that different behavior results from
invoking this method with either a class name or an object reference.
In the case of a class name, the verifier is added to the list of
verifiers for all objects of this class.  In the case of an object
reference, the verifier will only be used to verify the field values
for this particular object.  The process of verification involves
first checking that all of the class-wide verifiers pass, and if they
do, then subsequently checking all of the object specific verifiers.

=item save

 $obj->save()

This method saves the in memory representation of an object to the
database.  An actual write to the database will only occur if any
fields have been set via the set_field_values() method since the
object was loaded or last saved.  The primary key assigned to the
object is returned as a convenience.

=item delete

 $obj->delete()

This method deletes the object from the database, as specified by its
primary key, presuming that this object is in fact in the database.

=item get_parents

 $obj->get_parents($link_table_name)

This method returns a list of parent objects for this object from
$link_table_name that have been loaded, either explicitly with the
load_relatives method, or as part of a query of a collection of
objects.

=item get_children

 $obj->get_children($link_table_name)

This method returns a list of child objects for this object from
$link_table_name that have been loaded, either explicitly with the
load_relatives method, or as part of a query of a collection of
objects.

=item get_table_name

 $obj->get_table_name()

This method returns the name of the table associated with the subclass
of which the invoking object is an instance.  This method must be
overridden by the subclass for things to work.

=item get_schema

 $obj->get_schema()

This method returns an instance of the class PROP::Schema that
corresponds to the table specified by the get_table_name() method.
This object is populated upon the first execution of the method by
querying the database.

=back

=head1 Author

Andrew Gibbs (awgibbs@awgibbs.com,andrew.gibbs@nist.gov)

=head1 Legalese

This software was developed at the National Institute of Standards and
Technology by employees of the Federal Government in the course of
their official duties. Pursuant to title 17 Section 105 of the United
States Code this software is not subject to copyright protection and
is in the public domain. PROP is an experimental system. NIST
assumes no responsibility whatsoever for its use by other parties, and
makes no guarantees, expressed or implied, about its quality,
reliability, or any other characteristic. We would appreciate
acknowledgement if the software is used.  This software can be
redistributed and/or modified freely provided that any derivative
works bear some notice that they are derived from it, and any modified
versions bear some notice that they have been modified.
