File Coverage

blib/lib/Devel/EnforceEncapsulation.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	10	10	100.0
condition	4	4	100.0
subroutine	17	17	100.0
pod	2	2	100.0
total	103	103	100.0

#######################################################################
#      $URL: svn+ssh://[e-mail]/home/equilibrious/Mirror/medialandscape/repos/clotho/Devel-EnforceEncapsulation/lib/Devel/EnforceEncapsulation.pm $
#     $Date: 2014-03-27 18:57:41 -0500 (Thu, 27 Mar 2014) $
#   $Author: equilibrious $
# $Revision: 3356 $
########################################################################

package Devel::EnforceEncapsulation;

use warnings;
use strict;
use English qw(-no_match_vars);
use Carp;
use overload;

our $VERSION = '0.51';

sub apply_to {
   my $pkg      = shift;
   my $dest_pkg = shift;
   my $opts     = shift || {};

   $opts->{policy} ||= 'croak';
   if (!eval { $pkg->can('_deref_overload_' . $opts->{policy}) }) {
      croak "Unknown encapsulation policy '$opts->{policy}'";
   }

   ## no critic(ProhibitStringyEval,RequireCarping)
   my $fn = __PACKAGE__ . '::_deref_overload_' . $opts->{policy};
   my $overloads = join q{,}, map { "'$_' => \\&$fn" } $pkg->_ops;
   eval "{package $dest_pkg; use overload $overloads, fallback => 1;}";
   die $EVAL_ERROR if $EVAL_ERROR;
   return;
}

sub remove_from {
   my $pkg      = shift;
   my $dest_pkg = shift;

   ## no critic(ProhibitStringyEval,RequireCarping)
   my $overloads = join q{,}, map { "'$_'" } $pkg->_ops;
   eval "{package $dest_pkg; no overload $overloads, 'fallback';}";
   die $EVAL_ERROR if $EVAL_ERROR;
   return;
}

## possible callbacks to be installed via overload ##

sub _deref_overload_croak {
   my $self = shift;

   my $caller_pkg = caller;
   if (!$self->isa($caller_pkg)) {
      my $pkg = ref $self;
      croak "Illegal attempt to access $pkg internals from $caller_pkg";
   }
   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;

   ## no critic(ProhibitPackageVars)
   return split m/\s/xms, $overload::ops{dereferencing};
}

1;

__END__