view release on metacpan or  search on metacpan

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

            unless ($methname =~ m/^(from|on_error|delegate)$/);
        $class->$methname(scalar(caller),
                          (ref($args) eq "ARRAY" ? @$args : $args));
    }
}

=head2 from($facetclass, $origclass)

Indicates that $facetclass is to be a facet class from $origclass.
This method must be called first before any B<Class::Facet> operation
on $facetclass.

=cut

sub from {
    my ($class, $facetclass, $origclass) = @_;
    no strict "refs";
    *{"${facetclass}::_facet_of"} = sub { $origclass };
    foreach my $miranda (qw(rescind error)) {
        *{"${facetclass}::facet_$miranda"} = \&{"_miranda_$miranda"};
    }
    *{"${facetclass}::AUTOLOAD"} = \&_miranda_AUTOLOAD;
}

=head2 delegate($facetclass, $methodname)

Indicates that the method named $methodname is to be delegated to the
original object without altering the parameters or the return value.
Is mostly equivalent to declaring a sub like this:

=for My::Tests::Below "delegate equivalent" begin

  sub foo {
    my (undef, $origself) = Class::Facet->selves(\@_);
    unshift(@_, $origself);
    goto $origself->can("foo");
  }

=for My::Tests::Below "delegate equivalent" end

except that the error management is better.

=cut

sub delegate {
    my ($class, $facetclass, @methods) = @_;
    foreach my $methodname (@methods) {
        no strict "refs";
        *{"${facetclass}::${methodname}"} = sub {
            my (undef, $origself) = Class::Facet->selves(\@_);
            unshift(@_, $origself);
            goto $origself->can($methodname);
        };
    }
}

=head2 on_error($facetclass, $sub)

Installs $sub as the error management callback method for $facetclass.
$sub will always be called as a class method in void context, and
should throw an exception with L<perlfunc/die>, L<Exception::Class> or
some such, and not return.  As shown in L</SYNOPSIS>, $sub should
accept the following named parameters:

=over

=item B<-file>

=item B<-line>

The filename and line number of the place in the code that invoked the
faulty operation.

=item B<-facetclass>

The facet class against which the error sub is being invoked.  This
will be $facetclass, unless $sub is the error management routine for
several facets at once.

=item B<-reason>

The reason why the error is thrown, as the name of the method in
B<Class::Facet> that triggered the error, or one of the special values
C<facet_error> (meaning that L</facet_error> was invoked manually) or
C<forbidden_method> (if one tries to invoke a forbidden method through
the facet object).

=item B<-details> (optional)

A message in english explaining the reason of the error.

=item B<-method> (optional)

Set when trying to invoke a method through a facet object, but this
method is neither delegated (using L</delegate>) nor defined in the
facet package.

=back

The default implementation (if C<on_error()> is not called) is to
throw a text message in english using L<perlfunc/die> that contains a
subset of the aforementioned information.

=cut

# See the default implementation of the error handler in L</_carp>.
sub on_error {
    my ($class, $facetclass, $sub) = @_;
    unless (ref($sub) eq "CODE") {
        $sub = "an undefined value" if ! defined $sub;
        croak("Class::Facet: cannot use $sub as an error handler");
    }
    no warnings "redefine"; no strict "refs";
    *{"${facetclass}::_facet_die"} = $sub;
}

=head2 make($facetclass, $origobject)

Returns a facet of $object in class $facetclass.  The returned facet
object is an ordinary hashref-based object, constructed like this:

=for My::Tests::Below "make structure" begin

    bless { delegate => $origobject }, $facetclass;

=for My::Tests::Below "make structure" end

and B<Class::Facet> will never use any other field in blessed hash
besides C<delegate>.  The facet class and facet constructor are
therefore free to add their own fields into the facet object.

=cut

sub make {
    my ($class, $facetclass, $origobject) = @_;
    
#	use Class::ISA;
#	use UNIVERSAL::can; 
	#Making a facet from a facet is forbidden !!!!
#	for my $int (Class::ISA::super_path($facetclass)) {
# 		eval {($int->can("from") && $int->can("delegate"))};
# 		throw App::CamelPKI::Error::User
# 			("Subclassing a facet is forbidden")
# 				if ($int->can("from") && $int->can("delegate"))';
#	}
	
    return bless { delegate => $origobject }, $facetclass;
}

=head2 selves($argslistref)

Interprets $argslistref as a reference to the argument list (@_) of a
class method, and modifies it in place by removing the first argument
(as L<perlfunc/shift> would do).  Returns a a ($facetself, $origself)
pair where $facetself is the facet object, and $origself is the
original object.

This class method is useful for creating custom facet methods, such as
the C<get_substuff> example in L</SYNOPSIS>.

=cut

sub selves {
    my ($class, $argslistref) = @_;
    my $facetobject = shift @$argslistref;
    return ($facetobject, $facetobject->{delegate});
}

=head1 MIRANDA METHODS

These methods can be called from any facet object, regardless of how
restricted the facet class; in capability discipline parlance, they
can thus be interpreted as unremovable rights, just like those
enumerated in the I<miranda warning> given by the police officer upon
arresting you.

=head2 facet_rescind()

Turns the facet into a useless object, that will not accept any
further method call.

=cut

sub _miranda_rescind {
    my ($self) = @_;
    bless $self, ref($self) . "::Rescinded";
}

=head2 facet_error(%named_args)

Throws an exception by invoking the error mechanism configured with
L</on_error> for this facet class.  This may be used from inside a
facetized method, so as to make error handling uniform.

=cut

sub _miranda_error {
    my $self = shift;
    push(@_, "???") if (@_ % 2);
    Class::Facet->_carp(ref($self), @_);
}

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

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 {
    return bless { }, "Foo::TheRealOne::SubStuff";
}

sub Foo::TheRealOne::SubStuff::facet_readonly { shift }

test "synopsis, BEGIN style" => sub {
    eval My::Tests::Below->pod_code_snippet("synopsis facet class");
    die $@ if $@;
    @Foo::TheRealOne::calls = ();
    my $facet = Foo::TheRealOne->new->facet_readonly;
    $facet->get_this();
    is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
    eval {
        $facet->set_that;
        fail("method should have thrown");
    };
    isnt($@, undef);
    is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
};

test 'synopsis, "use Class::Facet" style' => sub {
    eval "package Foo::ReadOnlyFacetToo;" .
        My::Tests::Below->pod_code_snippet("synopsis without BEGIN");
    die $@ if $@;
    @Foo::TheRealOne::calls = ();
    my $facet = Class::Facet->make
        ("Foo::ReadOnlyFacetToo", Foo::TheRealOne->new);
    $facet->get_this();
    is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
    eval {
        $facet->set_that;
        fail("method should have thrown");
    };
    isnt($@, undef);
    is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
};

test "facet structure" => sub {
    my $origobject = Foo::TheRealOne->new;
    my $facet = $origobject->facet_readonly;
    my $facetclass = "Foo::ReadOnlyFacet";
    my $facettoo = eval My::Tests::Below->pod_code_snippet
        ("make structure");
    die $@ if $@;
    is_deeply($facet, $facettoo);
};

test "transparently delegated method" => sub {
    local *Foo::TheRealOne::foo = sub { pass };
    eval "package Foo::ReadOnlyFacet; " .
        My::Tests::Below->pod_code_snippet("delegate equivalent");
    die $@ if $@;
    Foo::TheRealOne->new->foo();
};

test "bogus method calls in the facet look real" => sub {
    my $real = Foo::TheRealOne->new;
    my @errors;
    foreach my $object ($real, $real->facet_readonly) {
        eval { $object->glork(); };
        push(@errors, $@);
    }
    is(scalar(grep { defined } @errors), 2);
    ok($errors[1] =~ s/ReadOnlyFacet/TheRealOne/);
    is($errors[0], $errors[1]);
};

test "on_error and faceted-out methods" => sub {
    eval {
        Foo::TheRealOne->new->facet_readonly->set_this();
        fail;
    };
    like($@, qr/^forbidden method set_this/);
};

TODO:{
	local $TODO = "Defensiveness not implemented";
test "make defensiveness" => sub {
    @Bogus::SubFacet::ISA = qw(Foo::ReadOnlyFacet);
    my $object = Foo::TheRealOne->new;

    eval {
        Class::Facet->make("Bogus::SubFacet", $object);
        fail("subclassing a facet is a no-no");
    };

    @Foo::SubReal::ISA = qw(Foo::TheRealOne);
    Class::Facet->make("Foo::ReadOnlyFacet", Foo::SubReal->new);
    pass("->make works for subclasses too");
};
};