view release on metacpan or  search on metacpan

lib/Devel/EnforceEncapsulation.pm  view on Meta::CPAN

#######################################################################
#      $URL: svn+ssh://equilibrious@equilibrious.net/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__

=pod

=for stopwords  perlmonks.org  ben Jore  Signes

=head1 NAME

Devel::EnforceEncapsulation - Find access violations to blessed objects

=head1 SYNOPSIS

  package BankAccount;
  sub new {
     my $pkg = shift;
     return bless {}, $pkg;
  }
  sub balance {
     my $self = shift;
     return $self->{balance};
  }
  # ... etc. ...
  
  package main;
  Devel::EnforceEncapsulation->apply_to('BankAccount');
  my $acct = BankAccount->new();
  print $acct->balance(),"\n";  # ok