###########################################################
###########################################################
####################### Class::Privacy ####################
###########################################################
###########################################################

package Class::Privacy;

=head1 NAME

Class::Privacy

=head1 SYNOPSIS

	package Foo;
	use Class::Privacy;
	use strict;

	sub new {
		my $class = shift;
		my %options = @_;

		bless \%options, $class;
	}

	sub public {
		my $self = shift;
		$self->_private;
	}

	sub _private {
		my $self = shift;
		print "got to the treasure!\n";
	}

	package main;

	use Foo;
	use strict;
	my $f = new Foo (bar => 'baz');
	$f->public; # OK
	$f->_private; # croaks
	print $f->{baz}; # croaks

	# fine grained control

	package Foobar;
	use Class::Privacy qw(
			fail	confess
			method	_
			read	public
			write	private
				);

=head1 DESCRIPTION

Class::Privacy provides a simple way to add privacy to your classes
just by adding a line of code. This is good for testing your class
structure, and also for "quick and dirty" privacy.

Options to use() include:

=over 4

=item fail

What to do if a privacy violation occurs: carp, croak, cluck, or confess?

=item method, read, write

How to determine privacy violations. The method value is used
for method accesses; the read value for attempts to read object
attributes; and the write value for attempts to alter object
attributes. Possible values are "private" (any access outside
the class is forbidden), "public" (anything goes), and "_" (methods
and attributes beginning with an underscore are considered private -
note that access to non-hash data members will always be private
using this option).

=back

The defaults are to croak on a violation, to consider all data
access private, and to check the underscore for methods.

=head1 CAVEATS AND BUGS

Class::Privacy works by exporting over "bless" into your package.
What you are getting is not what you think! "bless" returns a proxy,
and all methods and attribute accesses have to go through that proxy.
Unfortunately, once you start lying, you have to keep lying. So we
export CORE::GLOBAL::ref to make sure references return the right (wrong)
value - of the now hidden object, rather than the proxy object in its
place. It also defines sensible OO "isa" and "can" methods. Unfortunately
I can find no way to redefine "UNIVERSAL::isa" and "UNIVERSAL::can"
without hitting infinite recursion....


Class::Privacy can cope with blessed arrayrefs, hashrefs and scalarrefs,
but nothing else. It also doesn't cope well with inheritance. If
you create objects with a call to $class->SUPER::new, then you
won't be private. On the other hand, subclasses which call into
your package will be private, but will probably ignore the options
you sent to "use". Solutions welcome.


B<UNTESTED>. I don't know if this is secure. I just think it is, based
on a simple test script.



=head1 AUTHOR

David Hugh-Jones (hughjonesd@yahoo.co.uk)

=head1 LICENSE

Copyright (c) 2002-2003 David Hugh-Jones
 All rights reserved. This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 VERSION

0.1


=cut

use Class::Privacy::Proxy;
use Class::Privacy::MethodProxy;
use Exporter;
use Data::Dumper;
use Carp qw/carp cluck confess croak/;

use strict;
use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS $VERSION/;

$VERSION = 0.1;
@ISA = qw/Exporter/;
@EXPORT_OK = qw/bless/;

sub METHOD () {0;}
sub DATAREAD () {1;}
sub DATAWRITE () {2;}


my %hiddens; # hash keys are MethodProxy objects
my %package_options;
my %defaults = qw(
	fail 	croak
	write	private
	method	_
	read	private
);

my $get_options;


sub CORE::GLOBAL::ref {
	my $obj = shift;

	return CORE::ref ($obj)
			unless CORE::ref ($obj) eq
				'Class::Privacy::MethodProxy';

	return CORE::ref ($hiddens{$obj});
}

# package methods

sub import {
	my ($package, %options) = @_;

	while (my ($option, $default) = each %defaults) {
		$options{$option} ||= $default;
	}
	$package_options{scalar caller} = \%options;
	$get_options = sub {
			my $package = shift;
			if ($package_options{$package}) {
					return %{ $package_options{$package} };
			} else {
				return %defaults;
			}
				};

	my $class = __PACKAGE__;
	$class->SUPER::export_to_level(1, undef, @EXPORT_OK);
}

sub bless {
	my ($object, $class) = @_;

	my $ref;
	$ref = CORE::ref $object
			if CORE::ref ($object) =~
				/^(ARRAY|CODE|SCALAR|HASH|REF|GLOB|LVALUE)$/;
	unless ($ref) {
		if (isa($object, 'HASH')) {
			$ref = 'HASH';
		} elsif (isa($object, 'ARRAY')) {
			$ref = 'ARRAY';
		} elsif (isa($object, 'SCALAR')) {
			$ref = 'SCALAR';
		}
	}

	CORE::bless($object, $class);

	my ($proxy, %proxy, @proxy);
	my $methprox;
	if ($ref eq 'HASH') {
		tie %proxy, 'Class::Privacy::Proxy', $object;
  		$methprox = CORE::bless
					(\%proxy, 'Class::Privacy::MethodProxy');
	} elsif ($ref eq 'ARRAY') {
		tie @proxy, 'Class::Privacy::Proxy', $object;
		$methprox = CORE::bless
					(\@proxy, 'Class::Privacy::MethodProxy');
	} elsif ($ref eq 'SCALAR') {
		tie $proxy, 'Class::Privacy::Proxy', $object;
		$methprox = CORE::bless
					(\$proxy, 'Class::Privacy::MethodProxy');
	} else {
		croak "Class::Privacy can't create tied proxy for object $object";
	}
	# create a new proxy object with $object hidden behind it
	# the proxy object is tied, and
	# handles data accesses of every sort (scalar,
	# hash, array). The reference to it is blessed
	# and handles methods. This gets round the Perl
	# "dereferencing bypasses tying" bug. Dereferencing
	# will always go to the tied proxy.

	$hiddens{$methprox} = $object;
	return $methprox;

}

# Static methods, not exported.
# We mustn't pollute MethodProxy's namespace!

sub _privacy_check {
	my $proxy = shift; # can be either type of proxy!
	my ($real, $method_flag, $accessor) = @_;

	# policy dependent options
	my %options = $get_options->(CORE::ref $real);

	my $f = __FILE__;
	$f =~ s/\.pm//;
	my @caller = caller(1);

	if ($caller[1] =~ /\Q$f\E/ or
			$caller[0] eq CORE::ref($real)
				) {
		# we're private!
		return;
	}
	#	if ($options{level} eq 'protected' and
	#			UNIVERSAL::isa($real, $caller[0])
	#				) {
	#		# we're protected and the user asked for this
	#		return;
	#	}

	my $option = $method_flag == DATAREAD ? $options{read} :
			( $method_flag == DATAWRITE ?
			$options{write} : $options{method}
				);

	if ($option eq '_') {
		return unless defined $accessor
					and substr ($accessor, 0, 1) eq '_';
	} elsif ($option eq 'public') {
		return;
	}

	# PRIVACY VIOLATION
	if (CORE::ref $options{fail} eq 'CODE') {
		$options{fail}->();
	}
	elsif ($options{fail} eq 'carp') {
		print STDERR "Privacy violation at $caller[1]" .
					" line $caller[2]\n";
	}
	elsif ($options{fail} eq 'cluck') {
		cluck 'Privacy violation';
	}
	elsif ($options{fail} eq 'croak') {
		print STDERR "Privacy violation at $caller[1]" .
					" line $caller[2]\n";
		die;
	}
	elsif ($options{fail} eq 'confess') {
		confess 'Privacy violation';
	}
}

sub _get_hidden { # called from MethodProxy
	# this needs to be sorted out
	my $proxy = shift;

	my @caller = caller;
	$caller[1] =~ s/MethodProxy\.pm//;
	my $f = __FILE__;
	$f =~ s/\.pm//;
	die "Privacy violation from package $caller[0] at $caller[1]"
			unless $caller[0] eq 'Class::Privacy::MethodProxy'
			and $caller[1] =~ /\Q$f\E/;
	return $hiddens{$proxy};
}


1;

##</code><code>##



package Class::Privacy::Proxy;

use strict;
use Class::Privacy qw/:access_types/;


my %hiddens = (
); # hash keys are Proxy objects


sub TIESCALAR {
	my $class = shift;

	my $f;
	$class->_tie(\$f, @_);
}

sub TIEHASH {
	my $class = shift;
	$class->_tie({}, @_);
}

sub TIEARRAY {
	my $class = shift;
	$class->_tie([], @_);
}

sub _tie {
	my $class = shift;
	my ($self, $hidden) = @_;

	$hiddens{"Class::Privacy::Proxy=$self"} = $hidden; # avoid tieing before we do this
	CORE::bless($self, $class);

	return $self;
}


sub DESTROY {
	my $self = shift;

	undef $hiddens{$self};
}

# methods for tied variables

sub FETCH {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, $_[0]);

	if ($hiddens{$self} =~ /\=ARRAY/) {
		return $hiddens{$self}->[$_[0]];
	} elsif ($hiddens{$self} =~ /\=HASH/) {
		return $hiddens{$self}->{$_[0]};
	} else {
		return $hiddens{$self};
	}
}

sub STORE {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, $_[0]);
	if ($hiddens{$self} =~ /\=ARRAY/) {
		$hiddens{$self}->[$_[0]] = $_[1];
	} elsif ($hiddens{$self} =~ /\=HASH/) {
		$hiddens{$self}->{$_[0]} = $_[1];
	} else {
		$hiddens{$self} = shift;
	}
}

sub DELETE {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, $_[0]);
	if ($hiddens{$self} =~ /\=ARRAY/)  {
		delete $hiddens{$self}->[$_[0]];
	} else {
		delete $hiddens{$self}->{$_[0]};
	}
}

sub EXISTS {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, $_[0]);
	if ($hiddens{$self} =~ /\=ARRAY/) {
		return exists $hiddens{$self}->[$_[0]];
	} else {
		return exists $hiddens{$self}->{$_[0]};
	}
}

# hashes only

sub FIRSTKEY {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, undef);
	# copied from Tie::Hash. Don't understand reason.
	my $a = scalar keys %{$hiddens{$self}};
	each %{ $hiddens{$self} };
}

sub CLEAR {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);

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

}

sub NEXTKEY {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, undef);
	each %{ $hiddens{$self} };
}


# arrays only


sub FETCHSIZE {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, undef);
	return $#{ $hiddens{$self} };
}

sub STORESIZE {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
	$#{ $hiddens{$self} } = shift;
}

sub POP {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
	pop @{$hiddens{$self} };
}

sub PUSH {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
	push @{$hiddens{$self} }, @_;
}

sub SHIFT {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
	shift @{$hiddens{$self} };
}

sub UNSHIFT {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
	unshift @{$hiddens{$self} }, @_;
}

sub SPLICE {
	my $self = shift;

	Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
	splice @{$hiddens{$self} }, @_;
}

1;

##</code><code>##


package Class::Privacy::MethodProxy;

use Class::Privacy;
use strict;
use vars qw/$AUTOLOAD/;
no warnings;

sub isa {
	my $obj = shift;
	my $class = shift;

	return $obj->UNIVERSAL::isa($class)
				unless CORE::ref $obj eq 'Class::Privacy::MethodProxy';
	return Class::Privacy::_get_hidden($obj)->isa($class);
}

sub can {
	my $obj = shift;
	my $method = shift;

	return $obj->can($method)
				unless CORE::ref $obj eq 'Class::Privacy::MethodProxy';
	return Class::Privacy::_get_hidden($obj)->can($method);
}


sub AUTOLOAD {
	my $self = shift;

	my $method = $AUTOLOAD;
	$method =~ s/.*:://;
	return if $method eq 'DESTROY';

	Class::Privacy::_privacy_check($self,
				Class::Privacy::_get_hidden($self), 0, $method);

	no strict 'refs';
	Class::Privacy::_get_hidden($self)->$method(@_);
}

1;