Permalink
Browse files

expand test coverage a bit

  • Loading branch information...
1 parent 01c9883 commit 8fe4e0d58c7df8f7a53e2f592d2d6d87bf6b2eae @rjbs committed Mar 23, 2009
Showing with 104 additions and 0 deletions.
  1. +37 −0 t/import-code.t
  2. +67 −0 t/lib/ClassUMS.pm
View
37 t/import-code.t
@@ -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 ClassUMS;
+
+my $parent_class = ClassUMS->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, 'ClassUMS', 'check ref of ParentClass');
+is(ref $child_class, 'ClassUMS', '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
67 t/lib/ClassUMS.pm
@@ -0,0 +1,67 @@
+use strict;
+use warnings;
+package ClassUMS;
+
+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;
+ },
+);
+
+use metamethod sub {
+ 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);
+};
+
+1;

0 comments on commit 8fe4e0d

Please sign in to comment.