package Class::Capsule;
$VERSION = '1.0';

use strict;
use Data::Dumper;
$Data::Dumper::Indent = 1;
use Pod::Usage;
use WeakRef;

# Here's the subtle magic.  Object instances are stored in this class-
# level hash, keyed by a unique memory address.  This is hecka clever!
my %data;

=head1 NAME

  Class::Capsule - Base Encapsulation Class for Objects

=head1 DESCRIPTION

  This class is designed to provide object data encapsulation, a requirement 
  of object oriented programming, and a reliable object interface.  Perl 
  has no access modifiers so data encapsulation is not facilitated by the 
  language.  The Capsule module remedies that deficiency.  You need only
  inherit from this class to encapsulate your child class instance data.

  I make every attempt to be Perlish in the design of this class, so it is 
  designed to be easily used.  As the SYNOPSIS shows, a functional data 
  class can be created entirely devoid of implementation.

  The class provides a default constructor and automatic set, get, and 
  delete methods.  I call these collectively: 'accessors'.  The class
  enforces encapsulation in child classes using the memory address key 
  method (props to Damian Conway).

  The default constructor, new(), takes a hash of parameters and calls the 
  appropriate set method to set their values, then resets the '_MODIFIED'
  instance variable to zero.  It calls '_init()' before returning if it is 
  provided in the child class.  This allows you to do error checking and 
  initialize the object as needed.

  The class uses AUTOLOAD to provide automatic accessor methods for 
  instance variables.  This is not as evil as it you may think.  Only the 
  accessors will be AUTOLOADed.  Non-accessors result in an error.  You 
  can and should provide your own accessor implementations as needed, but 
  you should follow the naming convention.  If you violate the naming 
  convention, the default accessors will exist anyway and you lose two 
  important benefits.

  First, AUTOLOADed accessors enforce a naming convention and therefore 
  a consistent interface for all child classes.  Set methods must begin 
  with 'set_'.  Get methods must begin with 'get_'.  Delete methods must 
  begin with 'del_'.  If you chose to name your accessors differently, 
  this benefit is foregone.

  Second, AUTOLOADed accessors count the number of times the object was 
  modified via 'set_' and 'del_'.  This is important for persistence.  
  For instance ;^), you need only save objects to your persistence store 
  if they have been modified.  If you choose to override the accessors, 
  you should make sure each set and delete method for which you write 
  implementations calls 'increment__MODIFIED()' within the method.  This 
  increments the '_MODIFIED' instance variable to flag the object as a 
  candidate for persistence.  Never set '_MODIFIED' via its accessor.   
  Reset it to zero with 'zero__MODIFIED' or increment it with 
  'increment__MODIFIED()'.

  The class level hash approach used to provide encapsulation 
  unfortunately also provides opacity.  Introspective methods, like 
  get_keys(), to_string() and to_string_all() are provided to compensate 
  for that.

  An equals() method is also provided to compare instance data.  This is 
  a shallow comparison and not recursive for contained objects.  Contained 
  objects are considered equal only if they ARE the same object (i.e. - 
  their references point to the same memory address).  Their contents are 
  not compared.

  The class provides a usage() method which dies with the SYNOPSIS, 
  ARGUMENTS, and OPTIONS from the class POD.  Use this when the class is 
  misused.

=head1 SYNOPSIS

  #### A child class.
  package CapsuleChild;

  use Class::Capsule;
  @ISA = qw(Class::Capsule);
  use strict;

  sub _init {
     my ( $self ) = @_;
	 die $self->usage( "Need a stooge" ) unless $self->get_stooge.
  }

  1;

  #### Using the child.
  # Create the object and create and set an attribute.
  my $c = CapsuleChild->new( stooge => 'Moe' );

  # Create and set an instance variable.
  $c->set_marx( 'Harpo' );

  # Get an instance variable.
  print $c->get_stooge . "\n";

  # Delete an instance variable.
  $c->del_stooge;

  # Get a Data::Dumper serialized object.
  print $c->to_string;

  # Get a Data::Dumper of all Capsule objects.
  print $c->to_string_all;
  print Class::Capsule::to_string_all();

  # Get the object package.
  print $c->get_package . "\n";

  # Get the object's keys as an array reference.
  my $keys = $c->get_keys;
  print Dumper $keys;

  # Check whether two objects have equal contents.
  my $d = CapsuleChild->new( stooge => 'Shemp' );
  if ( $c->equals( $d ) ) {
     print "EQUAL!\n";
  } else {
     print "NOT EQUAL!\n";
  }

=cut

=head1 METHODS

=head1 new()

  Accepts a hash of arguments and calls the appropriate 'set_' method.  
  Calls $self->_init().  Use _init() to further populate the object and 
  check whether required arguments were passed in.

=cut

sub new {

	my ( $caller, %params ) = @_;

	my $class = ref($caller) || $caller;
	my $self = bless \my($scalar), $class;	# $self is the object's memory address.
	$data{$self} = { self => $self };		# Stow the object as class data.

	for ( keys %params ) {					# Call the appropriate setter method.
		my $method = "set_" . $_;
		$self->$method( $params{$_} );
	}
	
	$self->zero__MODIFIED;					# Create the variable.

	weaken $data{$self}{self};

	$self->_init if $self->can( '_init' );	# Put child's initializer code here.

	return $self;
}

# Avert your eyes!  Evil approacheth!

# Actually, it's not that evil.  The problem with using AUTOLOADed accessors 
# is that it masks errors.  If you call a member that doesn't exist, 
# AUTOLOAD quietly creates one for you, when what you really need is an error.

# I use a naming convention for accessors to get around this.

sub AUTOLOAD {

	my ( $self, $new ) = @_;
	
	our $AUTOLOAD;

	$AUTOLOAD =~ /.*::(set_|get_|del_)(.+)/;

	# You're not following the naming convention!
	unless ( $2 ) {
		my $package = "Unknown";
		$package = $self->get_package if ref($self);
		my $error = "AUTOLOAD error:\nEither you're attempting to call a non-existent method ($AUTOLOAD())\nor you're not following the accessor naming convention.  Accessors must \nbegin with 'set_', 'get_', or 'del_' in\n$package";
		die $error;
	}

	# Setter.
	if ( $1 eq 'set_' ) {
		$data{$self}{$2} = $new;
		$self->increment__MODIFIED;
	# Deleter.
	} elsif ( $1 eq 'del_' ) {
		delete $data{$self}{$2};
		$self->increment__MODIFIED;
	}

	# Getter.
	return $data{$self}{$2} if exists $data{$self}{$2};
}

=head1 increment__MODIFIED()

  Takes no arguments and returns nothing.  Increments the '_MODIFIED' 
  instance variable.  This should be called internally by every 'set_' 
  and 'del_' method.  Use this to determine whether an object should 
  be saved in the persistence store.

=cut

sub increment__MODIFIED {

	my ( $self ) = @_;

	$data{$self}{_MODIFIED}++;
}

=head1 zero__MODIFIED()

  Takes no arguments and returns nothing.  Sets the '_MODIFIED'
  instance variable to zero.  Never set '_MODIFIED' unless you 
  are resetting it to zero with this method.

=cut

sub zero__MODIFIED {

	my ( $self ) = @_;

	$data{$self}{_MODIFIED} = 0;
}

=head1 get_<instance variable>()

  Takes no arguments.  Returns the value of an instance variable.

  Overriding the 'get_' methods differs from the usual approach.  Instead 
  of doing this internally,

  return $self->{foo};

  Do this,

  return $Class::Capsule::data{$self}{foo};

=cut

=head1 set_<instance variable>()

  Takes a scalar (can be a reference).  Sets the instance variable's 
  value and returns the new value.  If you override this method, make 
  sure you call 'increment__MODIFIED()' within the method.  This increments 
  the '_MODIFIED' instance variable to flag the object as a candidate for 
  persistence:

  $self->increment__MODIFIED;

  Overriding the 'set_' methods differs from the usual approach.  You 
  should always return the new value.  Instead of doing this internally,

  $self->{foo} = 1;
  return $self->{foo};

  Do this,

  $Class::Capsule::data{$self}{foo} = 1;
  return $Class::Capsule::data{$self}{foo};

=cut

=head1 del_<instance variable>()

  Takes no arguments.  Deletes the instance variable.  If you override
  this method, make sure you call 'increment__MODIFIED()' within the method.  
  This increments the '_MODIFIED' instance variable to flag the object as a 
  candidate for persistence:

  $self->increment__MODIFIED;

  There is really no reason to override the delete method.

=cut

=head1 get_package()

  Returns the package name for the object instance.

=cut

sub get_package {

	my ( $self ) = @_;

	return ref( $self );
}

=head1 get_keys()

  Provided to enhance transparency, this returns the current keys 
  as an array reference.  You still will not be able to break
  encapsulation though.  :D

=cut

sub get_keys {

	my ( $self ) = @_;

	my @keys;
	for ( keys %{$data{$self}} ) {
		next if /self/;
		push( @keys, $_ );
	}

	return \@keys;
}

=head1 to_string()

  Provided to enhance transparency, this returns the instance data.

=cut

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

	my $title = 'Instance of ' . $self->get_package;
	my $version_string = '$' . $self->get_package . '::' . 'VERSION';
	my $version = eval $version_string;
	$title .= " (VERSION $version)" if $version;

	my $line = '=' x length( $title );

	print "$title\n$line\n";

	for ( @{$self->get_keys} ) {
		next if /_MODIFIED/;
		my $method = 'get_' . $_;
		print " $_ = " . $self->$method() . "\n";
	}
}

=head1 to_string_all()

  Here is a little bonus.  This method dumps every object that inherits
  from Capsule, via Data::Dumper.  It can be called as an instance method 
  or Capsule class method.

=cut

sub to_string_all {

	my ( $self ) = @_;

	return Dumper \%data;
}

=head1 usage() 

  Takes a message string.  Dies printing SYNOPSIS, ARGUMENTS, and OPTIONS from 
  the class POD.

=cut

sub usage {

	my ( $self, $msg ) = @_;

	my $filepath = $self->get_package . ".pm";

	$filepath =~ s/::/\//g;

	pod2usage( -input => $INC{$filepath}, -verbose => 1, -msg => $msg );
}

=head1 equals()

  Compares the instances of two objects.  Returns 1 if they are equal and 
  0 if they are not.

=cut

sub equals {

	my ( $self, $object ) = @_;

	my $keys = $self->get_keys;

	for ( @$keys ) {
		my $method = "get_$_";
		return 0 unless $self->$method == $object->$method;
	}

	my $object_keys = $object->get_keys;

	for ( @$object_keys ) {
		my $method = "get_$_";
		return 0 unless $object->$method == $self->$method;
	}

	return 1;
}

=head1 PRE-REQUISITES

  WeakRef.pm, Pod::Usage.pm, Data::Dumper.pm

=cut

=head1 AUTHOR

  Todd Shoenfelt, original coding - 21 June 2002

=cut

1;