Category: Misc/OO programming
Author/Contact Info David Hugh-Jones (hughjonesd@yahoo.co.uk)
Description:

This was meant to propel me into friarhood but (dammit) that happened anyway. So it's more of a celebration. To show how far I can come, and still know so little.

Drop-in privacy for your classes. I'd be really interested to know:

  1. Does this work? Are there bugs? Can you evade it?
  2. Are there solutions for its bugs and limitations?
  3. Is it useful? Does it suck?

See the Class::Privacy POD for more details

 

###########################################################
###########################################################
####################### 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;
########################################################### ########################################################### ################### 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;
########################################################### ########################################################### ############### 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;
Replies are listed 'Best First'.
Re: Class::Privacy
by dash2 (Hermit) on Feb 15, 2002 at 11:52 UTC
    I should probably think about what the class is meant to achieve a bit more... at the moment, it probably does a decent job of guarding against accidental privacy violations. But there are several ways to get round it if you really want to. Some of them could be avoided by more use of file-scoped closures (and putting all 3 classes in one big file). But the fundamental one:

    package Foo;
use Class::Privacy;
#...

package Cracker;
my $f = new Foo;
CORE::bless $f, 'Foo';
$f->_violate_privacy; # works

    [download]

    ... seems very hard to get round. (Note that this still protects $f from data violation, because the underlying hash/array/whatever is still a tied proxy.)

    Unless there is a way to protect the object from reblessing, Class::Privacy can't really provide guaranteed privacy, and should probably be called Class::Encapsulation or something. One strategy might be to ensure that data calls always come via Foo from MethodProxy, but that doesn't protect you for methods like:

    sub _explode {
 die 'I decided to blow up';
}

    [download]

    dave hj~

[reply]
[d/l]
[select]

Back to Code Catacombs