view release on metacpan or  search on metacpan

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

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");
};
};

=end internals

=cut