###########################################################
###########################################################
####################### Class::Privacy ####################
###########################################################
###########################################################

package Class::Privacy;

=head1 NAME

Class::Privacy

=head1 SYNOPSIS

    package Foo;
    use Class::Privacy;
    use strict;

    sub new {
        my $class = shift;
        my %options = @_;

        bless \%options, $class;
    }

    sub public {
        my $self = shift;
        $self->_private;
    }

    sub _private {
        my $self = shift;
        print "got to the treasure!\n";
    }

    package main;

    use Foo;
    use strict;
    my $f = new Foo (bar => 'baz');
    $f->public; # OK
    $f->_private; # croaks
    print $f->{baz}; # croaks

    # fine grained control

    package Foobar;
    use Class::Privacy qw(
            fail    confess
            method    _
            read    public
            write    private
                );

=head1 DESCRIPTION

Class::Privacy provides a simple way to add privacy to your classes
just by adding a line of code. This is good for testing your class
structure, and also for "quick and dirty" privacy.

Options to use() include:

=over 4

=item fail

What to do if a privacy violation occurs: carp, croak, cluck, or confe
+ss?

=item method, read, write

How to determine privacy violations. The method value is used
for method accesses; the read value for attempts to read object
attributes; and the write value for attempts to alter object
attributes. Possible values are "private" (any access outside
the class is forbidden), "public" (anything goes), and "_" (methods
and attributes beginning with an underscore are considered private -
note that access to non-hash data members will always be private
using this option).

=back

The defaults are to croak on a violation, to consider all data
access private, and to check the underscore for methods.

=head1 CAVEATS AND BUGS

Class::Privacy works by exporting over "bless" into your package.
What you are getting is not what you think! "bless" returns a proxy,
and all methods and attribute accesses have to go through that proxy.
Unfortunately, once you start lying, you have to keep lying. So we
export CORE::GLOBAL::ref to make sure references return the right (wro
+ng)
value - of the now hidden object, rather than the proxy object in its
place. It also defines sensible OO "isa" and "can" methods. Unfortunat
+ely
I can find no way to redefine "UNIVERSAL::isa" and "UNIVERSAL::can"
without hitting infinite recursion....


Class::Privacy can cope with blessed arrayrefs, hashrefs and scalarref
+s,
but nothing else. It also doesn't cope well with inheritance. If
you create objects with a call to $class->SUPER::new, then you
won't be private. On the other hand, subclasses which call into
your package will be private, but will probably ignore the options
you sent to "use". Solutions welcome.


B<UNTESTED>. I don't know if this is secure. I just think it is, based
on a simple test script.



=head1 AUTHOR

David Hugh-Jones (hughjonesd@yahoo.co.uk)

=head1 LICENSE

Copyright (c) 2002-2003 David Hugh-Jones
 All rights reserved. This program is free software; you can redistrib
+ute it and/or
modify it under the same terms as Perl itself.

=head1 VERSION

0.1


=cut

use Class::Privacy::Proxy;
use Class::Privacy::MethodProxy;
use Exporter;
use Data::Dumper;
use Carp qw/carp cluck confess croak/;

use strict;
use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS $VERSION/;

$VERSION = 0.1;
@ISA = qw/Exporter/;
@EXPORT_OK = qw/bless/;

sub METHOD () {0;}
sub DATAREAD () {1;}
sub DATAWRITE () {2;}


my %hiddens; # hash keys are MethodProxy objects
my %package_options;
my %defaults = qw(
    fail     croak
    write    private
    method    _
    read    private
);

my $get_options;


sub CORE::GLOBAL::ref {
    my $obj = shift;

    return CORE::ref ($obj)
            unless CORE::ref ($obj) eq
                'Class::Privacy::MethodProxy';

    return CORE::ref ($hiddens{$obj});
}

# package methods

sub import {
    my ($package, %options) = @_;

    while (my ($option, $default) = each %defaults) {
        $options{$option} ||= $default;
    }
    $package_options{scalar caller} = \%options;
    $get_options = sub {
            my $package = shift;
            if ($package_options{$package}) {
                    return %{ $package_options{$package} };
            } else {
                return %defaults;
            }
                };

    my $class = __PACKAGE__;
    $class->SUPER::export_to_level(1, undef, @EXPORT_OK);
}

sub bless {
    my ($object, $class) = @_;

    my $ref;
    $ref = CORE::ref $object
            if CORE::ref ($object) =~
                /^(ARRAY|CODE|SCALAR|HASH|REF|GLOB|LVALUE)$/;
    unless ($ref) {
        if (isa($object, 'HASH')) {
            $ref = 'HASH';
        } elsif (isa($object, 'ARRAY')) {
            $ref = 'ARRAY';
        } elsif (isa($object, 'SCALAR')) {
            $ref = 'SCALAR';
        }
    }

    CORE::bless($object, $class);

    my ($proxy, %proxy, @proxy);
    my $methprox;
    if ($ref eq 'HASH') {
        tie %proxy, 'Class::Privacy::Proxy', $object;
          $methprox = CORE::bless
                    (\%proxy, 'Class::Privacy::MethodProxy');
    } elsif ($ref eq 'ARRAY') {
        tie @proxy, 'Class::Privacy::Proxy', $object;
        $methprox = CORE::bless
                    (\@proxy, 'Class::Privacy::MethodProxy');
    } elsif ($ref eq 'SCALAR') {
        tie $proxy, 'Class::Privacy::Proxy', $object;
        $methprox = CORE::bless
                    (\$proxy, 'Class::Privacy::MethodProxy');
    } else {
        croak "Class::Privacy can't create tied proxy for object $obje
+ct";
    }
    # create a new proxy object with $object hidden behind it
    # the proxy object is tied, and
    # handles data accesses of every sort (scalar,
    # hash, array). The reference to it is blessed
    # and handles methods. This gets round the Perl
    # "dereferencing bypasses tying" bug. Dereferencing
    # will always go to the tied proxy.

    $hiddens{$methprox} = $object;
    return $methprox;

}

# Static methods, not exported.
# We mustn't pollute MethodProxy's namespace!

sub _privacy_check {
    my $proxy = shift; # can be either type of proxy!
    my ($real, $method_flag, $accessor) = @_;

    # policy dependent options
    my %options = $get_options->(CORE::ref $real);

    my $f = __FILE__;
    $f =~ s/\.pm//;
    my @caller = caller(1);

    if ($caller[1] =~ /\Q$f\E/ or
            $caller[0] eq CORE::ref($real)
                ) {
        # we're private!
        return;
    }
    #    if ($options{level} eq 'protected' and
    #            UNIVERSAL::isa($real, $caller[0])
    #                ) {
    #        # we're protected and the user asked for this
    #        return;
    #    }

    my $option = $method_flag == DATAREAD ? $options{read} :
            ( $method_flag == DATAWRITE ?
            $options{write} : $options{method}
                );

    if ($option eq '_') {
        return unless defined $accessor
                    and substr ($accessor, 0, 1) eq '_';
    } elsif ($option eq 'public') {
        return;
    }

    # PRIVACY VIOLATION
    if (CORE::ref $options{fail} eq 'CODE') {
        $options{fail}->();
    }
    elsif ($options{fail} eq 'carp') {
        print STDERR "Privacy violation at $caller[1]" .
                    " line $caller[2]\n";
    }
    elsif ($options{fail} eq 'cluck') {
        cluck 'Privacy violation';
    }
    elsif ($options{fail} eq 'croak') {
        print STDERR "Privacy violation at $caller[1]" .
                    " line $caller[2]\n";
        die;
    }
    elsif ($options{fail} eq 'confess') {
        confess 'Privacy violation';
    }
}

sub _get_hidden { # called from MethodProxy
    # this needs to be sorted out
    my $proxy = shift;

    my @caller = caller;
    $caller[1] =~ s/MethodProxy\.pm//;
    my $f = __FILE__;
    $f =~ s/\.pm//;
    die "Privacy violation from package $caller[0] at $caller[1]"
            unless $caller[0] eq 'Class::Privacy::MethodProxy'
            and $caller[1] =~ /\Q$f\E/;
    return $hiddens{$proxy};
}


1;

[download]
########################################################### ########################################################### ################### Class::Privacy::Proxy ################# ########################################################### ########################################################### 


package Class::Privacy::Proxy;

use strict;
use Class::Privacy qw/:access_types/;


my %hiddens = (
); # hash keys are Proxy objects


sub TIESCALAR {
    my $class = shift;

    my $f;
    $class->_tie(\$f, @_);
}

sub TIEHASH {
    my $class = shift;
    $class->_tie({}, @_);
}

sub TIEARRAY {
    my $class = shift;
    $class->_tie([], @_);
}

sub _tie {
    my $class = shift;
    my ($self, $hidden) = @_;

    $hiddens{"Class::Privacy::Proxy=$self"} = $hidden; # avoid tieing 
+before we do this
    CORE::bless($self, $class);

    return $self;
}


sub DESTROY {
    my $self = shift;

    undef $hiddens{$self};
}

# methods for tied variables

sub FETCH {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, $_[0]);

    if ($hiddens{$self} =~ /\=ARRAY/) {
        return $hiddens{$self}->[$_[0]];
    } elsif ($hiddens{$self} =~ /\=HASH/) {
        return $hiddens{$self}->{$_[0]};
    } else {
        return $hiddens{$self};
    }
}

sub STORE {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, $_[0]);
    if ($hiddens{$self} =~ /\=ARRAY/) {
        $hiddens{$self}->[$_[0]] = $_[1];
    } elsif ($hiddens{$self} =~ /\=HASH/) {
        $hiddens{$self}->{$_[0]} = $_[1];
    } else {
        $hiddens{$self} = shift;
    }
}

sub DELETE {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, $_[0]);
    if ($hiddens{$self} =~ /\=ARRAY/)  {
        delete $hiddens{$self}->[$_[0]];
    } else {
        delete $hiddens{$self}->{$_[0]};
    }
}

sub EXISTS {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, $_[0]);
    if ($hiddens{$self} =~ /\=ARRAY/) {
        return exists $hiddens{$self}->[$_[0]];
    } else {
        return exists $hiddens{$self}->{$_[0]};
    }
}

# hashes only

sub FIRSTKEY {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, undef);
    # copied from Tie::Hash. Don't understand reason.
    my $a = scalar keys %{$hiddens{$self}};
    each %{ $hiddens{$self} };
}

sub CLEAR {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);

    foreach (keys %{ $hiddens{$self} }) {
        delete $hiddens{$self}->{$_};
    }

}

sub NEXTKEY {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, undef);
    each %{ $hiddens{$self} };
}


# arrays only


sub FETCHSIZE {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 1, undef);
    return $#{ $hiddens{$self} };
}

sub STORESIZE {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
    $#{ $hiddens{$self} } = shift;
}

sub POP {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
    pop @{$hiddens{$self} };
}

sub PUSH {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
    push @{$hiddens{$self} }, @_;
}

sub SHIFT {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
    shift @{$hiddens{$self} };
}

sub UNSHIFT {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
    unshift @{$hiddens{$self} }, @_;
}

sub SPLICE {
    my $self = shift;

    Class::Privacy::_privacy_check($self, $hiddens{$self}, 2, undef);
    splice @{$hiddens{$self} }, @_;
}

1;

[download]
########################################################### ########################################################### ############### Class::Privacy::MethodProxy ############### ########################################################### ########################################################### 

package Class::Privacy::MethodProxy;

use Class::Privacy;
use strict;
use vars qw/$AUTOLOAD/;
no warnings;

sub isa {
    my $obj = shift;
    my $class = shift;

    return $obj->UNIVERSAL::isa($class)
                unless CORE::ref $obj eq 'Class::Privacy::MethodProxy'
+;
    return Class::Privacy::_get_hidden($obj)->isa($class);
}

sub can {
    my $obj = shift;
    my $method = shift;

    return $obj->can($method)
                unless CORE::ref $obj eq 'Class::Privacy::MethodProxy'
+;
    return Class::Privacy::_get_hidden($obj)->can($method);
}


sub AUTOLOAD {
    my $self = shift;

    my $method = $AUTOLOAD;
    $method =~ s/.*:://;
    return if $method eq 'DESTROY';

    Class::Privacy::_privacy_check($self,
                Class::Privacy::_get_hidden($self), 0, $method);

    no strict 'refs';
    Class::Privacy::_get_hidden($self)->$method(@_);
}

1;

[download]

In reply to Class::Privacy by dash2

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.