[libclass-virtual-perl] 03/07: Works and passes tests.
dom at earth.li
dom at earth.li
Wed Aug 23 14:00:14 UTC 2017
This is an automated email from the git hooks/post-receive script.
dom pushed a commit to tag v0.03
in repository libclass-virtual-perl.
commit ed5a6b658d6d54ce400b3f257a6f2e0ec513ecb8
Author: Michael G. Schwern <schwern at pobox.com>
Date: Tue Nov 28 03:03:35 2000 +0000
Works and passes tests.
git-svn-id: file:///Users/schwern/tmp/svn/CPAN/Class-Virtual/trunk@2273 8151f2b9-fde8-0310-94fd-f048d12aab9e
---
MANIFEST | 4 ++
Makefile.PL | 7 +-
lib/Class/Virtual.pm | 194 +++++++++++++++++++++++++++++++++++++++++++++++++++
t/Virtual.t | 41 ++++++++++-
4 files changed, 242 insertions(+), 4 deletions(-)
diff --git a/MANIFEST b/MANIFEST
index e69de29..f763a20 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -0,0 +1,4 @@
+MANIFEST
+Makefile.PL
+lib/Class/Virtual.pm
+t/Virtual.t
diff --git a/Makefile.PL b/Makefile.PL
index 06b0a66..3d56540 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -9,7 +9,7 @@ use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
-$PACKAGE = 'Module::Name';
+$PACKAGE = 'Class::Virtual';
($PACKAGE_FILE = $PACKAGE) =~ s|::|/|g;
$LAST_API_CHANGE = 0;
@@ -28,7 +28,10 @@ CHANGE_WARN
WriteMakefile(
NAME => $PACKAGE,
VERSION_FROM => "lib/$PACKAGE_FILE.pm", # finds $VERSION
- PREREQ_PM => { },
+ PREREQ_PM => {
+ Class::Data::Inheritable => 0.02,
+ Class::ISA => 0.31,
+ },
'dist' => { COMPRESS => 'gzip -9',
SUFFIX => '.gz',
DIST_DEFAULT => 'all tardist',
diff --git a/lib/Class/Virtual.pm b/lib/Class/Virtual.pm
index ea8d5a3..834206a 100644
--- a/lib/Class/Virtual.pm
+++ b/lib/Class/Virtual.pm
@@ -1,2 +1,196 @@
package Class::Virtual;
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+use Class::ISA;
+# Class::ISA doesn't export?!
+*self_and_super_path = \&Class::ISA::self_and_super_path;
+
+use base qw(Class::Data::Inheritable);
+__PACKAGE__->mk_classdata('__Virtual_Methods');
+
+
+=pod
+
+=head1 NAME
+
+Class::Virtual - Base class for virtual base classes.
+
+
+=head1 SYNOPSIS
+
+ package My::Virtual::Idaho;
+ use base qw(Class::Virtual);
+
+ __PACKAGE__->virtual_methods(new foo bar this that);
+
+
+ package My::Private::Idaho;
+ use base qw(My::Virtual::Idaho);
+
+ # Check to make sure My::Private::Idaho implemented everything
+ my @missing = __PACKAGE__->missing_methods;
+ die __PACKAGE__ . ' forgot to implement ' . join ', ', @missing
+ if @missing;
+
+ # If My::Private::Idaho forgot to implement new(), the program will
+ # halt and yell about that.
+ my $idaho = My::Private::Idaho->new;
+
+ # See what methods we're obligated to implement.
+ my @must_implement = __PACKAGE__->virtual_methods;
+
+
+=head1 DESCRIPTION
+
+This is a base class for implementing virtual base classes. Kinda
+kooky. It allows you to explicitly declare what methods are virtual
+and that must be implemented by subclasses. This might seem silly,
+since your program will halt and catch fire when an unimplemented
+virtual method is hit anyway, but there's some benefits.
+
+The error message is more informative. Instead of the usual
+"Can't locate object method" error, you'll get one explaining that a
+virtual method was left unimplemented.
+
+Subclass authors can explicitly check to make sure they've implemented
+all the necessary virtual methods. When used as part of a regression
+test, it will shield against the virtual method requirements changing
+out from under the subclass.
+
+Finally, subclass authors can get an explicit list of everything
+they're expected to implement.
+
+Doesn't hurt and it doesn't slow you down.
+
+
+=head2 Methods
+
+=over 4
+
+=item B<virtual_methods>
+
+ Virtual::Class->virtual_methods(@virtual_methods);
+ my @must_implement = Sub::Class->virtual_methods;
+
+This is an accessor to the list of virtual_methods. Virtual base
+classes will declare their list of virtual methods. Subclasses will
+look at them. Once the virtual methods are set they cannot be undone.
+
+XXX I'm tempted to make it possible for the subclass to override the
+XXX virtual methods, perhaps add to them. Too hairy to think about for
+XXX 0.01.
+
+=cut
+
+#"#
+sub virtual_methods {
+ my($class) = shift;
+
+ if( @_ ) {
+ if( defined $class->__Virtual_Methods ) {
+ require Carp;
+ Carp::croak("Attempt to reset virtual methods.");
+ }
+ $class->_mk_virtual_methods(@_);
+ }
+ else {
+ return @{$class->__Virtual_Methods};
+ }
+}
+
+
+sub _mk_virtual_methods {
+ no strict 'refs'; # symbol table mucking! Getcher goloshes on.
+
+ my($this_class, @methods) = @_;
+
+ $this_class->__Virtual_Methods(\@methods);
+
+ # private method to return the virtual base class
+ *__virtual_base_class = sub {
+ return $this_class;
+ };
+
+ foreach my $meth (@methods) {
+ # Make sure the method doesn't already exist.
+ if( $this_class->can($meth) ) {
+ require Carp;
+ Carp::croak "$this_class attempted to declare $meth() virtual ".
+ "but it appears to already be implemented!";
+ }
+
+ # Create a virtual method.
+ *{$meth} = sub {
+ my($self) = shift;
+ my($class) = ref $self || $self;
+
+ require Carp;
+
+ if( $class eq $this_class) {
+ my $caller = caller;
+ Carp::croak "$caller called the virtual base class ".
+ "$this_class directly! Use a subclass instead";
+ }
+ else {
+ Carp::croak "$class forgot to implement $meth()";
+ }
+ };
+ }
+}
+
+
+=pod
+
+=item B<missing_methods>
+
+ my @missing_methods = Sub::Class->missing_methods;
+
+Returns a list of methods Sub::Class has not yet implemented.
+
+=cut
+
+sub missing_methods {
+ my($class) = shift;
+
+ my @vmeths = $class->virtual_methods;
+ my @super_classes = self_and_super_path($class);
+ my $vclass = $class->__virtual_base_class;
+
+ # Remove everything in the hierarchy beyond, and including,
+ # the virtual base class. They don't concern us.
+ my $sclass;
+ do {
+ $sclass = pop @super_classes;
+ } until $sclass eq $vclass;
+
+ my @missing = ();
+
+ {
+ no strict 'refs';
+ METHOD: foreach my $meth (@vmeths) {
+ CLASS: foreach my $class (@super_classes) {
+ next METHOD if defined &{$class.'::'.$meth};
+ }
+
+ push @missing, $meth;
+ }
+ }
+
+ return @missing;
+}
+
+=pod
+
+=back
+
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern at pobox.com>
+
+=cut
+
+return "Club sandwich";
diff --git a/t/Virtual.t b/t/Virtual.t
index 7418280..4d6add7 100644
--- a/t/Virtual.t
+++ b/t/Virtual.t
@@ -14,7 +14,7 @@ my $test_num = 1;
BEGIN { $| = 1; $^W = 1; }
END {print "not ok $test_num\n" unless $loaded;}
print "1..$Total_tests\n";
-use Module::Name;
+use Class::Virtual;
$loaded = 1;
ok(1, 'compile');
######################### End of black magic.
@@ -51,4 +51,41 @@ sub eqarray {
}
# Change this to your # of ok() calls + 1
-BEGIN { $Total_tests = 1 }
+BEGIN { $Total_tests = 7 }
+
+my @vmeths = qw(new foo bar this that);
+my $ok;
+
+package Test::Virtual;
+use base qw(Class::Virtual);
+__PACKAGE__->virtual_methods(@vmeths);
+
+::ok( ::eqarray([sort __PACKAGE__->virtual_methods], [sort @vmeths]),
+ 'Declaring virtual methods' );
+
+eval {
+ __PACKAGE__->virtual_methods(qw(this wont work));
+};
+$ok = $@ =~ /^Attempt to reset virtual methods/;
+::ok( $ok, "Disallow reseting by virtual class" );
+
+
+package Test::This;
+use base qw(Test::Virtual);
+
+::ok( ::eqarray([sort __PACKAGE__->virtual_methods], [sort @vmeths]),
+ 'Subclass listing virtual methods');
+::ok( ::eqarray([sort __PACKAGE__->missing_methods], [sort @vmeths]),
+ 'Subclass listing missing methods');
+
+*foo = sub { 42 };
+*bar = sub { 23 };
+
+::ok( ::eqarray([sort __PACKAGE__->missing_methods], [sort qw(new this that)]),
+ 'Subclass handling some methods');
+
+eval {
+ __PACKAGE__->virtual_methods(qw(this wont work));
+};
+$ok = $@ =~ /^Attempt to reset virtual methods/;
+::ok( $ok, "Disallow reseting by subclass" );
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-virtual-perl.git
More information about the Pkg-perl-cvs-commits
mailing list