Permalink
Browse files

more tests! classless, named metamethod, misc.

  • Loading branch information...
1 parent e2a01e8 commit bd90d184a2d3a009a07f18c8d058c95b1387dbdd @rjbs committed Mar 23, 2009
Showing with 215 additions and 2 deletions.
  1. +1 −2 lib/metamethod.pm
  2. +37 −0 t/alt-name.t
  3. +47 −0 t/classless.t
  4. +58 −0 t/lib/CLR.pm
  5. +71 −0 t/lib/ClassMMN.pm
  6. +1 −0 t/misc-errors.t
View
@@ -23,9 +23,8 @@ sub import {
my $metamethod = $arg->{metamethod_name} || '__metamethod__';
if (reftype $code eq 'SCALAR') {
- $code = $caller->can($$code);
Carp::confess("can't find metamethod via name ${ $arg->{metamethod} }")
- unless $code and reftype $code eq 'CODE';
+ unless $code = $caller->can($$code);
}
if (do { no strict 'refs'; defined *{"$caller\::$metamethod"}{CODE} }) {
View
@@ -0,0 +1,37 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+# *all* this is meant to do is test a class that says:
+# use metamethod sub { ... }
+
+use lib 't/lib';
+require ClassMMN;
+
+my $parent_class = ClassMMN->new({
+ name => 'ParentClass',
+ class_methods => { ping => sub { 'pong' }, pong => sub { 'ping' } },
+ instance_methods => { plugh => sub { 'fool' }, y2 => sub { 'y2' } },
+});
+
+my $child_class = $parent_class->new_subclass({
+ name => 'ChildClass',
+ class_methods => { ping => sub { 'reply' }, foo => sub { 'bar' } },
+ instance_methods => { plugh => sub { 'xyzzy' }, foo => sub { 'fee' } },
+});
+
+is(ref $parent_class, 'ClassMMN', 'check ref of ParentClass');
+is(ref $child_class, 'ClassMMN', 'check ref of ChildClass');
+
+is($parent_class->name, 'ParentClass', 'name of ParentClass');
+is($child_class->name, 'ChildClass', 'name of ChildClass');
+
+is($parent_class->ping, 'pong', 'ping ParentClass');
+is($child_class->ping, 'reply', 'ping ChildClass');
+
+is($parent_class->pong, 'ping', 'pong ParentClass');
+is($child_class->pong, 'ping', 'pong ChildClass');
+
+eval { $parent_class->foo };
+like($@, qr/no class method/, 'no "foo" on ParentClass');
+is($child_class->foo, 'bar', 'foo on ChildClass');
View
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+use Test::More 'no_plan';
+use lib 't/lib';
+use CLR;
+
+my $root_a = CLR->new;
+my $child_a = $root_a->new(status => sub { 'OK!' });
+my $child_b = $child_a->new(status => sub { 'ok?' });
+
+eval { $root_a->status };
+like($@, qr/\Aunknown method status called on CLR obj/, "no status on root");
+
+is(
+ $child_a->status,
+ 'OK!',
+ 'child object answers status method',
+);
+
+is(
+ $child_b->status,
+ 'ok?',
+ 'grandchild object answers status method, too',
+);
+
+$child_a->set(generation => 2);
+
+my $call;
+
+is(
+ $root_a->get('generation'),
+ undef,
+ 'no generation value on root',
+);
+
+is(
+ $child_a->get('generation'),
+ 2,
+ 'we got a generation value from child',
+);
+
+is(
+ $child_a->get('generation'),
+ 2,
+ '...which is inherited by the grandchild',
+);
+
View
@@ -0,0 +1,58 @@
+use strict;
+use warnings;
+package CLR; # class-less root
+# Our test example will be a very, very simple classless/prototype calling
+# system. -- rjbs, 2008-05-16
+
+sub new {
+ my ($class, %attrs) = @_;
+ my $root = {
+ new => sub {
+ my ($parent, %attrs) = @_;
+ bless { %attrs, parent => $parent } => $class;
+ },
+ get => sub {
+ my ($self, $attr) = @_;
+ my $curr = $self;
+ while ($curr) {
+ return $curr->{$attr} if exists $curr->{$attr};
+ $curr = $curr->{parent};
+ }
+ return undef;
+ },
+ set => sub {
+ my ($self, $attr, $value) = @_;
+ return $self->{$attr} = $value;
+ },
+ %attrs,
+ parent => undef,
+ };
+
+ bless $root => $class;
+}
+
+my %STATIC = (new => \&new);
+
+use metamethod
+ passthru => [ qw(import export) ],
+ metamethod => sub {
+ my ($invocant, $method, $args) = @_;
+
+ unless (ref $invocant) {
+ die "no metaclass method $method on $invocant"
+ unless my $code = $STATIC{$method};
+
+ return $code->($invocant, @$args);
+ }
+
+ my $curr = $invocant;
+ while ($curr) {
+ return $curr->{$method}->($invocant, @$args) if exists $curr->{$method};
+ $curr = $curr->{parent};
+ }
+
+ my $class = ref $invocant;
+ die "unknown method $method called on $class object";
+};
+
+1;
View
@@ -0,0 +1,71 @@
+use strict;
+use warnings;
+package ClassMMN; # metamethod_name
+
+our $VERSION = '1.234';
+
+my %STATIC = (
+ new => sub {
+ my ($pkg, $arg) = @_;
+ my $class = bless $arg => $pkg;
+ },
+);
+
+my %UNIVERSAL = (
+ new => sub { bless { __class__ => $_[0] } => $_[0]->instance_class, },
+ name => sub { $_[0]->{name} },
+ base => sub { $_[0]->{base} },
+ new_subclass => sub {
+ my ($class, $arg) = @_;
+ my $pkg = ref $class;
+ my $new = { %$arg, base => $class };
+ bless $new => $pkg;
+ },
+ instance_class => sub { 'Instance' },
+ class_methods => sub { $_[0]->{class_methods} },
+ instance_methods => sub { $_[0]->{instance_methods} },
+ derives_from => sub {
+ my ($self, $super) = @_;
+
+ # Nothing wrong with this! -- rjbs, 2009-03-21
+ return unless (ref $self)->UNIVERSAL::isa(__PACKAGE__);
+
+ my $curr = $self;
+ while ($curr) {
+ return 1 if $curr == $super;
+ $curr = $curr->base;
+ }
+ return;
+ },
+);
+
+sub invoke_method {
+ my ($invocant, $method_name, $args) = @_;
+ my $curr = $invocant;
+ my $code;
+
+ unless (ref $invocant) {
+ die "no metaclass method $method_name on $invocant"
+ unless $code = $STATIC{$method_name};
+
+ return $code->($invocant, @$args);
+ }
+
+ while ($curr) {
+ my $methods = $curr->{class_methods};
+ $code = $methods->{$method_name}, last
+ if exists $methods->{$method_name};
+ $curr = $curr->{base};
+ }
+
+ Carp::confess("no class method $method_name on $invocant->{name}")
+ unless $code ||= $UNIVERSAL{$method_name};
+
+ $code->($invocant, @$args);
+};
+
+use metamethod
+ metamethod => \'invoke_method',
+ metamethod_name => '__M__';
+
+1;
View
@@ -28,3 +28,4 @@ use metamethod ();
ok( ! $ok, "we can't provide metamethod by name if it doesn't exist");
like($error, qr/can't find/, "... got the right error, more or less");
}
+

0 comments on commit bd90d18

Please sign in to comment.