view release on metacpan or  search on metacpan

lib/Class/Facet.pm  view on Meta::CPAN

=head1 REFERENCES

Capabilities and secure programming:
L<http://www.c2.com/cgi/wiki?CapabilitySecurityModel>,
L<http://www.erights.org/elib/capability/ode/index.html>

The Law of Demeter, a well-known best practice in object-oriented
programming that also happens to be a preliminary step to capability
discipline: L<http://www.c2.com/cgi/wiki?LawOfDemeter>

The E programming language: L<http://wiki.erights.org/wiki/Walnut>

Capabilities in Perl: L<http://caperl.links.org/>

The concept of facets: L<http://www.c2.com/cgi/wiki?FacetPattern>,
L<http://wiki.erights.org/wiki/Walnut/Secure_Distributed_Computing/Capability_Patterns#Facets>

Why facets and inheritance don't mix: FIXME add link

=head1 DISCLAIMER

Users of this package should be warned that B<Class::Facet> doesn't
provide any actual security of its own, as stated in L</So how secure
is this?>.  The author therefore makes B<no warranty>, implied or
otherwise, about the suitability of this software for any purpose
whatsoever.

The authors shall not in any case be liable for special, incidental,
consequential, indirect or other similar damages arising from the use
of this software.

Your mileage will vary. If in any doubt do not use it.

=begin internals

=head1 INTERNALS

B<Class::Facet> strives to be as unintrusive as possible, so as to
hide itself from the rest of the code; this is not for security, but
rather for testability (code that works with a ``normal'' object
should work out-of-the-box with a facet instead).

The facet class does B<not> inherit from the original class; rather,
it works by delegation, and delegating stubs are created on demand by
B<Class::Facet>.  Additionally, L</_miranda_AUTOLOAD> accounts for the
methods that exist in the original object, but not the facet object.

=head2 _carp($facetclass, %named_args)

Throws an error using $facetclass' configured error handler.
%named_args is a (flat) hash of named options similar to those
documented in L</on_error>; the C<-file>, C<-line> and C<-facetclass>
will be filled out (if not already present) and the resulting
associative array will be passed to the C<$sub> error handler declared
with C<on_error()>, if any.

=cut

sub _carp {
    my ($class, $facetclass, %args) = @_;
    my (undef, $filename, $line) = caller(1);
    $args{-facetclass} ||= $facetclass;
    $args{-file}       ||= $filename;
    $args{-line}       ||= $line;
    if (my $die = $facetclass->can("_facet_die")) {
        $die->($facetclass, %args);
    }
    # Still here? Either $die didn't, or there is no on_error handler.
    if (exists(&{"${facetclass}::"})) {
        no strict "refs";
        &{"${facetclass}::_facet_die"}(%args);
    }
    $args{-details} ||= "Class::Facet error";
    croak "$args{-details} ($args{-reason})"
        . " at $args{-file} line $args{-line}\n";
};


=head2 _miranda_AUTOLOAD

Installed as the facet class' AUTOLOAD method by L</from>.  Therefore,
as per L</perlsub/Autoloading>, I<_miranda_AUTOLOAD> catches calls to
functions that are unknown to the facet class.  If this call is to an
instance method (B<not> class method) of the original object,
I<_miranda_AUTOLOAD> invokes L</facet_error> on the facet object; in
all other cases (unknown method, function or class method call),
I<_miranda_AUTOLOAD> emulates Perl's original error message so as to
pretend that the function actually doesn't exist.

=cut

sub _miranda_AUTOLOAD {
    my ($thispackage, $methname);
    {
        no strict "refs";
        # ${"AUTOLOAD"} resolves to the $AUTOLOAD variable in whatever
        # package the sub will be transplanted to. This is just so
        # deliciously evil :-)
        ($thispackage, $methname) = (${"AUTOLOAD"} =~ m/^(.*)::(.*?)$/);
    }
    return if $methname eq "DESTROY";
    if ((ref($_[0]) eq $thispackage) &&
        ($_[0]->{delegate}->can($methname))) {
        Class::Facet->_carp($thispackage, -method => $methname,
                            -reason => "forbidden_method");
    }
    my (undef, $file, $line) = caller();
    die sprintf(qq{Can't locate object method "%s" via package "%s" }
                . qq{at %s line %d.\n},
                $methname, $thispackage, $file, $line);
}

require My::Tests::Below unless caller;
1;

__END__

=head1 TEST SUITE

=cut

use Test::More qw(no_plan);
use Test::Group;

test "import" => sub {
    no warnings "redefine";
    our @calls;
    local *Class::Facet::from = sub { shift; push (@calls, "from", \@_) };
    local *Class::Facet::delegate = sub
        { shift; push (@calls, "delegate", \@_) };
    foreach my $snip ("import use simple",
                      "import converted into method calls",
                      "import use multiple") {
        @calls = ();
        my $callerpackage = "Foo::ReadOnlyFacet";
        eval "package $callerpackage; " .
            My::Tests::Below->pod_code_snippet($snip); die $@ if $@;
        is_deeply(\@calls,
                  [ from => [ "Foo::ReadOnlyFacet", "foo" ],
                    delegate => [ "Foo::ReadOnlyFacet", "bar", "baz" ] ]);
    }
};

=head2 Foo::TheRealOne

The bogus original class defined in L</SYNOPSIS> is the basis for all
tests.  The methods are all stubbed down to simply pushing a marker
into @Foo::TheRealOne::calls whenever they are called.

=cut

my $synopsis = My::Tests::Below->pod_code_snippet("synopsis main class");
$synopsis =~ s/sub get_substuff.*//g;
$synopsis =~ s|sub (.*) { \.\.\. }|sub $1 { push(our \@calls, "$1"); }|g;
eval $synopsis; die $@ if $@;

sub Foo::TheRealOne::new { bless {}, shift }
sub Foo::TheRealOne::in_a_bad_mood { 0 } # Lucky you!

=head2 Foo::TheRealOne::SubStuff

The class of the object returned by C<Foo::TheRealOne::get_substuff>.
Obviously no less bogus than the rest of the test fixture.

=cut

sub Foo::TheRealOne::get_substuff {