package Myco::Base::Entity;

###############################################################################
# $Id: Entity.pm,v 1.1.1.1 2004/11/22 19:16:01 owensc Exp $
#
# See license and copyright near the end of this file.
###############################################################################

=head1 NAME

Myco::Base::Entity - common base class for all Myco entity classes.

=head1 SYNOPSIS

 ### Entity class definition

 package Myco::Foo;
 use base qw(Myco::Base::Entity);

 # Start building metadata
 my $metadata = Myco::Base::Entity::Meta->new
  ( name => __PACKAGE__,
    tangram => { table => 'Foo' }
  );

 $metadata->add_attribute(name => 'attr1', type => 'string');
 $metadata->add_attribute(name => 'attr2', type => 'string');

 #    class-specific methods defined ...
 #

 # Fill in $schema with all added_attributes and discover other metadata
 $metadata->activate_class;



 ### Entity class usage

 use Myco::Foo;

 # Constructor
 $obj = Myco::Foo->new;
 $obj = Myco::Foo->new(attr1 => value, attr2 => value);

 # Access class metadata (see Myco::Base::Entity::Meta)
 $meta = Myco::Foo->introspect;
 $meta = $obj->introspect;

 # Accessors
 $obj->get_attr1;              # get attribute value
 $obj->set_attr1('value');     # set attribute value

 # Instance methods
 $id = $obj->save;             # update object's state in persistent
                               # storage, create new record if needed;
                               # returns object's Tangram id
 $obj->destroy;
 $obj->modify(attr1 => val, attr2 => val);
 $object_id = $obj->id;
 $obj->is_transient;           # returns true if object is in Tangram
                               # transient storage

 ## object retrieval (see class Myco documentation
 #    for full detail)

 $obj = Myco->load($object_id);

 # fetch all objects of given type
 @objects = Myco->select(ref $obj);


=head1 DESCRIPTION

Provides, via inheritence, common interface in support of basic lifecycle
needs for myco entity objects.

This is accomplished through the encapsulation of the CPAN module
Class::Tangram which provides a basis for "in-memory" object behavior.
Consult its documentation for details on schema definition syntax,
getter/setter behavior, check functions, etc.

The common interface for object persistence behavior (referred within
myco as "transaction" behavior) is provided through defintion of a handful
of related instance methods.  This is done with reliance on the services of
the class Myco, which encapsulates the functionality of Tangram::Storage and
provides system-wide connection handling.

=cut

### an object of this class ISA
use base qw(Class::Tangram);

### Module Dependencies and Compiler Pragma
use warnings;
use strict;
use Myco::Exceptions;
use Set::Object;
use Tangram::RawDateTime;
use Myco::Base::Entity::Meta;

# Any other entity class dependencies must appear after next section
#  this class (next line) doesn't want the 'template' attribs
use Myco::Base::Entity::Event;
use Myco::Util::DateTime;

use constant EVENT => 'Myco::Base::Entity::Event';
use constant DATETIME => 'Myco::Util::DateTime';

### Template attributes (_added_ [not inherited] to scheme of all sub-classes)
my $md = Myco::Base::Entity::Meta->new
  ( name => __PACKAGE__ );

$md->add_attribute(name => 'owner_',
                   template => 1,
		   type => 'ref',
		   tangram_options => {  class => 'Myco::Person', },
                  );

$md->add_attribute(name => 'changedate_',
                   template => 1,
		   type => 'rawdatetime',
                  );
$md->add_attribute(name => 'changedby_',
                   template => 1,
		   type => 'ref',
		   tangram_options => {  class => 'Myco::User', },
                  );

$md->add_attribute(name => 'createdate_',
                   template => 1,
		   type => 'rawdatetime',
                  );
$md->add_attribute(name => 'createdby_',
                   template => 1,
		   type => 'ref',
		   tangram_options => {  class => 'Myco::User', },
                  );

$md->activate_class;


### Entity class dependencies
# See bogus (compile loop breaking) placement of
#     Myco::UI::Auth loading in new()

### Class variables
my $_event_cache;

=head1 CLASS SETUP

Class meta data and object schema definition is managed via
L<Myco::Base::Entity::Meta|Myco::Base::Entity::Meta>.  Typical
class setup begins like this:

 package Foo;
 use base qw(Myco::Base::Entity);
 my $metadata = Myco::Base::Entity::Meta->new
  ( name => __PACKAGE__,
    tangram => { table => 'foo' }
  );

The 'tangram' parameter passes in an anonymous hash containing a
L<Class::Tangram|Class::Tangram>-style schema definition [but --without-- a
'fields' key!].  The creation of the $metadata object is normally followed
by one or more calls to C<$metadata-E<gt>add_attribute()> each of which
adds an attribute to the schema, along with establishing associated metadata.

At the very end of the class file comes the following, which triggers a
final phase of metadata discovery and makes the object schema active.

 $metadata->activate_class;

=head2 Class setup in Class::Tangram $schema style

Alternately the schema may be specified as a fully laid-out $schema data
structure, with no C<$metadata->E<gt>add_attribute() calls.  In this
case the C<activate_class()> method will parse $schema and fill out the
$metadata object with what it finds.  This may be of use when converting
an existing class or when the Class::Tangram style is simply preferred.

=over 4

=item B<import_schema> [deprecated]

 Myco::Base::Entity::import_schema('Myco::Foo');

Informs Class::Tangram about classE<39>s schema so it can take care of
in-memory behavior.  ***If Myco::Base::Entity::Meta is in use then direct
use of this method should be avoided.

=cut

sub import_schema {
    Class::Tangram::import_schema($_[0]);
}

=back

=head1 CONSTRUCTOR

=over 4

=item B<new>

 $obj = Myco::Foo->new;
 $obj = Myco::Foo->new(attr1 => value, attr2 => value);

Object constructor.  See Class::Tangram documentation.  Will throw an
exception if a required attribute is missing from parameter list.

=back

=cut

##############################################################################
# Constants
##############################################################################

=head1 CLASS / INSTANCE METHODS

See Class::Tangram for other available methods.

=head2 new

  $obj->set(attribute => $value, ...);

Constructs the new object. Overrides C<Class::Tangram::set()> in order to
initiate the Event Cache.

=cut

sub new {

    # Don't want this here... but it'll do for now
#    require Myco::UI::Auth;

    my $invocant = shift;
    my $class = ref $invocant || $invocant || '';

    my $entity = $class->SUPER::new(@_);


### DISABLED FOR NOW
#    # find the immediate caller
#    my $i = 0;
#    $i++ while UNIVERSAL::isa( $entity, scalar(caller($i)) || ";->" );
#    unless ( caller($i) =~ /Tangram/ ) {
#        $entity->set_createdate_( DATETIME->date('YYYY-MM-DD') );
#        my $u = Myco::UI::Auth->get_current_user;
#        $entity->set_createdby_($u) if $u;
#    }

    unless ($class eq EVENT) {
        $_event_cache =  EVENT->get_event_cache
          unless $_event_cache;
        # Initiate the Event Cache with a 'Create' event.
        EVENT->new( entity => $entity, kind => 1 );
    }
    return $entity;
}

sub DESTROY {
    my $self = shift;
    # Check if this is itself an event object
    unless (ref $self eq EVENT) {
        delete $_event_cache->{"$self"} if exists $_event_cache->{"$self"};
    }
    $self->SUPER::DESTROY(@_);
}

=head2 set

  $obj->set(attribute => $value, ...);

Sets the value of an attribute. Overrides C<Class::Tangram::set()> in order to
enforce access control.

=cut

sub _set {
    my $self = shift;
    # No point in continuing if they're not specifying any attributes to set!
    return unless @_;
    if (my $u = Myco::UI::Auth->get_current_user) {
        # Check for access.
        my $md = $self->introspect;
        my $uroles = $u->get_roles_hash;
      CLASS: {
            if (%$uroles) {
                my $al = $md->get_access_list;
                # If there are no roles on this class, jump out of the block.
                # This should probably be changed at some point so that the
                # access becomes better enforced.
                last CLASS unless $al->{rw} || $al->{ro};
                # Only check read/write for set().
                my $croles = $al->{rw} || [];
                foreach my $cr (@$croles) {
                    # If the role exists, class-level access is granted. Jump
                    # out of this block.
                    last CLASS if $uroles->{$cr};
                }
                # If we get here, they simply don't have permission to access
                # objects of this class.
                Myco::Exception::Authz->throw
                  (error => "You do not have permission to edit " .
                   ref $self . " objects");
            }
        } # CLASS:
        # Okay, if we get here, they have permission to access objects of
        # this class. Now let's check the attributes they're trying to
        # set.
        my $attrs = $md->get_attributes;
        my %params = @_;
        my @nope;
      ATTR: {
            foreach my $attr (keys %params) {
                my $al = $attrs->{$attr}->get_access_list;
                # If there are no attribute roles, skip to the next
                # attribute. This should probably be changed at some point
                # so that the access becomes better enforced.
                next ATTR unless $al->{rw} || $al->{ro};
                # Only check read/write for set().
                if (my $aroles = $al->{rw}) {
                    foreach my $ar (@$aroles) {
                        # Skip to the next attribute if they have permission to
                        # access the current attribute.
                        next ATTR if $uroles->{$ar};
                        # Otherwise, save this attribute name.
                        push @nope, $attr;
                    }
                } else {
                    # No read/write roles, so access is denied.
                    push @nope, $attr;
                }
            }
        } # ATTR:
        # Now check to see if we grabbed any attributes that they can't
        # access.
        if (@nope) {
            my $pl = $#nope == 0 ? '' : 's';
            local $" = "', '";
            Myco::Exception::Authz->throw
                ( error => "You do not have permission to edit the '@nope' " .
                  "attribute$pl of " . ref $self . " objects");
        }
    }
    # Put each attribute in the event cache before leaving to do the SUPER::set
    if (ref $self ne EVENT) {
        my %params = @_;
        foreach my $attr (keys %params) {
            #
            # implement code to:
            # skip if the object does not have an ID (i.e. its only transient)
            #
#            _build_event_cache( $self, $attr, $params{$attr} );
        }
    }

    # We now return to our regularly-scheduled set method.
    $self->SUPER::set(@_);
}

=head2 get

  my $value = $obj->get($attribute);

Returns the value of an attribute. Overrides C<Class::Tangram::get()> in order
to enforce access control.

=cut

sub _get {
    my $self = shift;
    # No point in continuing if they're not specifying an attributes to get!
    return unless $_[0];
    if (my $u = Myco::UI::Auth->get_current_user) {
        # Check for access.
        my $md = $self->introspect;
        my $uroles = $u->get_roles_hash;
      CLASS: {
            if (%$uroles) {
                my $al = $md->get_access_list;
                # Get the class roles or, if there are none, jump out of the
                # loop. This should probably be changed at some point so that
                # the access becomes better enforced.
                last CLASS unless $al->{rw} || $al->{ro};
                # We check both read/write and read only for the get() method.
                my $rw = $al->{rw} || [];
                my $ro = $al->{ro} || [];
                foreach my $cr (@$rw, @$ro) {
                    # Jump out of this block if they have permission.
                    last CLASS if $uroles->{$cr};
                }
                # If we get here, they simply don't have permission to access
                # objects of this class.
                Myco::Exception::Authz->throw
                    (error => "You do not have permission to read " .
                     ref $self . " objects");
            }
        } # CLASS:
        # Okay, if we get here, they have permission to access this class.
        # Now let's check the attributes they're trying to get.
        my $attrs = $md->get_attributes;
      ATTR: {
            # They can fetch only one attribute at a time, according to the
            # Class::Tangram spec for get().
            my $attr = $_[0];
            my $al = $attrs->{$attr}->get_access_list;
            # If there are no attribute roles, bugger out. This should
            # probably be changed at some point so that the access becomes
            # better enforced.
            last ATTR unless $al->{rw} || $al->{ro};
            # We check both read/write and read only for the get() method.
            my $rw = $al->{rw} || [];
            my $ro = $al->{ro} || [];
            foreach my $ar (@$rw, @$ro) {
                # Jump out of this block if they have permission.
                last ATTR if $uroles->{$ar};
            }
            # If we get here, they don't have permission.
            Myco::Exception::Authz->throw
              (error => "You do not have permission to read the '$attr' " .
               "attribute of " . ref $self . " objects");
        } # ATTR:
    }
    # We now return to our regularly-scheduled get method.
    $self->SUPER::get(@_);
}

=over 4

=item B<save>

 $id = $obj->save;

Updates database state to be consistent with objectE<39>s current in-memory
representation.  If object is not already persistent, it is inserted into
the database.  The Tangram object ID is returned.

=cut

sub save {
    my $self = shift;

#    my $u = Myco::UI::Auth->get_current_user || undef;
#    $self->set_owner_($u->get_person) if $u;

    if ( Myco->is_transient($self) ) {
#        $self->set_changedby_($u) if $u;
#        $self->set_changedate_( DATETIME->date('YYYY-MM-DD') );
        Myco->update($self);
        Myco->id($self);
    } else {
        Myco->insert($self);
    }
}


=item B<destroy>

 $obj->destroy;

Removes object from persistent storage and does its best to remove
it from memory as well.  This memory cleanup process includes:

=over 3

=item *

Clearing all attributes that hold references to other objects (via a call to $obj->clear_refs.  See L<Class::Tangram|Class::Tangram>).

=item *

Clearing the Tangram transient storage reference to object.

=item *

Setting to undef the caller object reference.  If no other references to
the object exist Perl will do its usual garbage collection.


=back

This method is just an encapsulation of the call 'Myco->destroy($obj)'.

=cut

#Removes object from persistent storage and does the best it can to remove
#it from memory as well (as with any Perl data structure the object will not
#be freed from memory if any other references to it exist).

sub destroy { Myco->destroy($_[0]) }


# deprecated?
sub attr_kill_handle {
    return \ $_[0]->{$_[1]};
}


=item B<modify>

 $obj->modify(attr1 => value, attr2 => value);

Modifies one or more object attributes and updates objectE<39>s persistence
storage state as well.

=cut

sub modify {
	my ($self, %params) = @_;
	while ( my($key, $value) = each %params ) {
		$self->$key($value);
	}
	Myco->storage->update($self);
}


=item B<id>

 $id = $obj->id;

Returns the Tangram persistence object identifier (typcially for use with later
calls to Myco->load() ).

=cut

sub id { Myco->id($_[0]) };

=item B<is_transient>

 if ($obj->is_transient) { ... };

Returns true if object is currently in Tangram transient storage.

=cut

sub is_transient { Myco->is_transient($_[0]) };
	
=item B<introspect>

 $meta = Myco::Foo->introspect;
 $meta = $obj->introspect;

Returns the Myco::Base::Entity::Meta metadata object that describes the
referent, or undef if none exists.

=cut

# introspect() is implemented in Myco::Base::Entity::Meta, which installs
#   it in the entity class when $metadata->activate_class() is called.


# private...  [used by Myco::Program::enroll() ...]?
sub _remove_base_assoc_member {
    my ($self, $member, $group_arg) = @_;
    my $class = ref($self) || $self;
    if (!ref($self) && !$group_arg) {
        Myco::Exception::DataValidation->throw
          (error => "Method syntax error - ${class}->something needs a " .
                    "$class as second argument");
    }
    my $group = $group_arg || $self;

    if ( $group_arg && (ref($group_arg) ne $class) ) {
#	my ($class, $sub) = @{ [ caller($self) ] }[0,3];
#       Myco::Exception::DataValidation->throw
#	  (error => "Method syntax error - ${class}->${sub} needs a " .
#                   "$class as a second argument");
#	$class =  ref $self;
        Myco::Exception::DataValidation->throw
	  (error => "Method syntax error - ${class}->something needs a " .
                    "$class as second argument");
    }

    my $member_r = Myco->remote(ref $member);
    my $group_r = Myco->remote(ref $group);
    my $assoc_r = Myco->remote('Myco::Base::Association');
	
    my $cur = Myco->cursor($assoc_r, ($member_r==$member)
			   & $member_r->{stuff}->includes($assoc_r)
			   & $group_r->{members}->includes($assoc_r)
			   & ($group_r==$group));
    my $assoc = $cur->current;
    return undef unless ($assoc);
    $member->stuff->remove($assoc);
    $group->members->remove($assoc);
    Myco->update($member);
    Myco->update($group);
    $group->destroy(\$assoc);
    return 1;
}

1;
__END__


=head1 SEARCHING AND LOADING

Retrieval of objects from persistent storage is accomplished via related
class methods of the class Myco.  See L<Myco|Myco>.

=back

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2004 the myco project. All rights reserved.
This software is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 AUTHOR

Charles Owens <owensc@enc.edu>

=head1 SEE ALSO

L<Myco::Base::Entity::Meta|Myco::Base::Entity::Meta>,
L<Class::Tangram|Class::Tangram>,
L<Tangram|Tangram>,
L<Myco::Test::EntityTest|Myco::Test::EntityTest>,
L<Myco|Myco>,
L<mkentity|mkentity>

=cut
