| Subject: | allow warning on violations [PATCH] |
This would be useful to find and correct violations in non-100%-covered
production code -- but only if it wasn't fatal.
Here's a patch to make that possible.
--
rjbs
| Subject: | carp.patch |
diff -Nur Devel-EnforceEncapsulation-0.01.old/lib/Devel/EnforceEncapsulation.pm Devel-EnforceEncapsulation-0.01/lib/Devel/EnforceEncapsulation.pm
--- Devel-EnforceEncapsulation-0.01.old/lib/Devel/EnforceEncapsulation.pm 2006-10-11 08:29:28.000000000 -0400
+++ Devel-EnforceEncapsulation-0.01/lib/Devel/EnforceEncapsulation.pm 2006-10-11 09:01:58.000000000 -0400
@@ -18,9 +18,17 @@
sub apply_to {
my $pkg = shift;
my $dest_pkg = shift;
+ my $arg = shift || {};
+
+ if (
+ $arg->{policy} && ! eval { $pkg->can("_deref_overload_$arg->{policy}") }
+ ) {
+ Carp::croak "unknown encapsulation policy '$arg->{policy}'";
+ }
## no critic(ProhibitStringyEval,RequireCarping)
- my $fn = __PACKAGE__ . '::_deref_overload';
+ my $fn = __PACKAGE__ . '::_deref_overload'
+ . ($arg->{policy} ? "_$arg->{policy}" : '');
my $overloads = join q{,}, map { "'$_' => \\&$fn" } $pkg->_ops;
eval "{package $dest_pkg; use overload $overloads;}";
die $EVAL_ERROR if $EVAL_ERROR;
@@ -50,6 +58,17 @@
return $self;
}
+sub _deref_overload_carp {
+ my $self = shift;
+
+ my $caller_pkg = caller;
+ if (!$self->isa($caller_pkg)) {
+ my $pkg = ref $self;
+ carp "Illegal attempt to access $pkg internals from $caller_pkg";
+ }
+ return $self;
+}
+
# get a list of overloadable derefs ('%{}', '@{}', '${}', ...)
sub _ops {
my $pkg = shift;
diff -Nur Devel-EnforceEncapsulation-0.01.old/t/api.t Devel-EnforceEncapsulation-0.01/t/api.t
--- Devel-EnforceEncapsulation-0.01.old/t/api.t 2006-10-11 08:29:28.000000000 -0400
+++ Devel-EnforceEncapsulation-0.01/t/api.t 2006-10-11 09:02:05.000000000 -0400
@@ -1,6 +1,6 @@
use warnings;
use strict;
-use Test::More tests => 47;
+use Test::More tests => 51;
BEGIN
{
@@ -117,6 +117,23 @@
eval { my $val = $$o; };
ok $@, 'Scalar direct access';
+Devel::EnforceEncapsulation->remove_from('Hash_class');
+{
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { $warned++; };
+
+ $o = Hash_class->new;
+ $o->foo(3);
+ is $o->{secret}, 3, 'Unencapsulated classes are once again not affected';
+ is $warned, 0, "no warning on unencapsulated class";
+
+ Devel::EnforceEncapsulation->apply_to('Hash_class', { policy => 'carp' });
+ $o = Hash_class->new;
+ $o->foo(3);
+ is $o->{secret}, 3, "encapsulation with carp doesn't prevent access";
+ is $warned, 1, "...but it does raise a warning";
+}
+
exit;
{ package Hash_class;