package protect;

$VERSION = '1.00a';

use Carp;
use Exporter;
@ISA = qw ( Exporter );
@EXPORT = qw ( is members );

$protect::debug = 0;
$protect::nowarn = 0;
%memberstruct;

sub nowarn {
	$nowarn = 1;
}

sub members {
	my $caller = caller();
	my $cnt = 1;
	$memberstruct->{$caller}[0] = $caller;
	print "Declaring members for $memberstruct->{$caller}[0](@_)\n" if
		$protect::debug;
	foreach my $member (@_) {
		$memberstruct->{$caller}[$cnt] = $member;
		print "Made $memberstruct->{$caller}[$cnt] a member of $caller\n"
			if $protect::debug;
		$cnt++;
	}
}

sub member {
	my $num = shift || 1;
	my ($caller,@rest) = caller(1);
	my ($package, $file, $line, $subname, @other) = caller($num);
	my $ismember;
	foreach $member (@{$memberstruct->{$caller}}) {
		print "Checking to see if $member is a member of $caller\n"
			if $protect::debug;
		if ($member eq $package) {
			$ismember = 1;	
		}
	}
	unless ($ismember) {
  	  print "member sub $subname called by non-member class in $file line $line\n"
			unless $nowarn;

	  exit(1);
	}
}

sub private {
	my $num = shift || 1;
	print "Number of stacks to shift in hunt for caller: $num\n" if $debug;
	my ($caller,$file,$line,$subname, @others) = caller($num);
	my ($backcaller, @oth) = caller(1);
	unless ($caller eq $backcaller) {
	  print "Called from $caller\n" if $debug;
	  print "private sub $subname called outside class in $file line $line\n"
			unless $nowarn;
	  exit(1);
	}
}

sub public { print "subs are automatically public\n" if $protect::debug }

sub is { 
	my $type = shift;
	if ($type eq 'private') {
		private(2);
	} elsif ($type eq 'member') {
		member(2);
	} elsif ($type eq 'public') {
		public();
	} else {
		croak "cannot assign $type attribute to subroutine";
	}
}

sub debug {
	$debug = shift;
}

1;


__END__

=head1 NAME

  protect - allows the declaration of protected subs

=head1 SYNOPSIS

  package FooPackage;
  use protect;

  members qw ( Bar Baz );

  sub foo {
	is private;
	print "Only FooPackage can use me\n";
  }

  sub foz {
	is member;
	print "Only packages FooPackage, Bar, and Baz can use me.\n";
  }

  sub fail {
	is public;
	print "Anybody can use me!\n";
  }

=head1 DESCRIPTION

  This module allows you to C<protect> your subs from outside callers, in a
way similar to C++ or Java.  You can declare member subs, private subs, or
public subs.
  The truth is, unfortunatly, that the subs aren't actually being declared,
public, member, or private. What actually happens is a juicy bit of runtime
checking, with perl's C<caller()> function to see where the subroutine call is 
coming from. 

=head1 FUNCTION is

  C<is> is allows you to declare set the subroutine as one of three modes.

=head1 MODES

  The following are all modes that can be set by using the is function.

=item MODE private

  By setting your subroutine as C<private>, no-one can call it from outside
the package that it was declared in.  Doing so will cause the program to
die.

=item MODE member

  By setting the C<member> mode, only the current package and those 
packages that are declared as C<members> of the current package are 
allowed to call the subroutine.

=item MODE public

  By declaring C<public> you are actually doing nothing at all, but it looks
nice to declare a function public, when every other sub is declared
something or other.

=head1 FUNCTION members

  C<members> allows you to declare members of the current package family,
and therefore use subroutines declared as member. members'ing is one way
only. ie 'Just because you lent me your basketball, doesn't mean I'll lend 
you mine'. 

=head1 FUNCTION nowarn

  C<nowarn> allows you to have protect simply die without explaining why it
did so.  This is in order to help restrict attacks where it is possible for
people to see the runtime errors generated by the script.

=head1 BUGS

  C<private> and C<member> methods/functions can still be redefined without 
the private/member attribute.

  Both private and member methods/functions can be called by simply entering
the package that they were declared in.

=head1 FIXES

  C<protect> now exports a lot less into the namespace, thanks to the
wonders of C<is>.

  C<members> and C<member> functions now work like they should.

=head1 AUTHOR

  James Duncan <jduncan@hawk.igs.net>

=head1 SEE ALSO

  perl(1), perlfunc(1) 

=cut
