The problem, of course, is in the
my $PACKAGE = caller(0);
happening at package level.
Below is an implementation of your approach which is entirely scalable.
It doesn't "remember" anything from 'import' time; it simply compares the
package of the caller to the package of the callee, and requires that they
be the same.
package Private;
use Exporter;
@ISA = 'Exporter';
@EXPORT = 'is_private';
use strict;
use warnings;
use Carp;
sub is_private()
{
my %c0; @c0{qw( pkg fn l sub )} = caller 0;
my %c1; @c1{qw( pkg fn l sub )} = caller 1;
if ( $c0{'pkg'} ne $c1{'pkg'} ) # throw an exception:
{
my %c2; @c2{qw( pkg fn l sub )} = caller 2;
my $caller = $c2{'sub'} || $c2{'pkg'} || 'main';
croak "$caller cannot call $c1{'sub'} (private to $c0{'pkg'})"
+;
}
}
1;
Here's a little test rig.
{
package Parent;
use Private;
sub private_method { is_private; print "Private method calleed OK.\n
+" }
sub public_method { $_[0]->private_method }
}
{
package Child;
use base 'Parent';
sub child_calling_private { $_[0]->private_method }
sub child_calling_public { $_[0]->public_method }
}
package main;
print "\nBase class: call private method directly:\n";
eval { Parent->private_method }; $@ and print $@;
print "\nBase class: call public method that calls private method:\n";
eval { Parent->public_method; }; $@ and print $@;
print "\nDerived class: call parent's private method directly:\n";
eval { Child->private_method }; $@ and print $@;
print "\nDerived class: call parent's public method that calls private
+ method:\n";
eval { Child->public_method; }; $@ and print $@;
print "\nDerived class: call method that calls parent's private method
+:\n";
eval { Child->child_calling_private; }; $@ and print $@;
print "\nDerived class: call method that calls parent's public method:
+\n";
eval { Child->child_calling_public; }; $@ and print $@;