[libclass-virtual-perl] 07/07: 0.03 Fri Mar 2 01:33:07 EST 2001 * Officially distributing Class::Virtually::Abstract * Virtual responsibility was leaking across all virtual classes - Started using Carp::Assert
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 5978c09524afaac1b085de4036f97e01b385f137
Author: Michael G. Schwern <schwern at pobox.com>
Date: Fri Mar 2 07:39:17 2001 +0000
0.03 Fri Mar 2 01:33:07 EST 2001
* Officially distributing Class::Virtually::Abstract
* Virtual responsibility was leaking across all virtual classes
- Started using Carp::Assert
git-svn-id: file:///Users/schwern/tmp/svn/CPAN/Class-Virtual/trunk@2278 8151f2b9-fde8-0310-94fd-f048d12aab9e
---
Changes | 14 +++++
MANIFEST | 3 +
Makefile.PL | 1 +
lib/Class/Virtual.pm | 24 +++++---
lib/Class/Virtually/Abstract.pm | 129 ++++++++++++++++++++++++++++++++++++++++
t/{Virtual.t => Abstract.t} | 87 ++++++++++++++++++++-------
t/Virtual.t | 32 +++++++++-
7 files changed, 260 insertions(+), 30 deletions(-)
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..5bfdebd
--- /dev/null
+++ b/Changes
@@ -0,0 +1,14 @@
+Change log for Perl module Class::Virtual
+
+0.03 Fri Mar 2 01:33:07 EST 2001
+ * Officially distributing Class::Virtually::Abstract
+ * Virtual responsibility was leaking across all virtual classes
+ - Started using Carp::Assert
+
+0.02 Fri Feb 9 13:17:34 GMT 2001
+ - Fixed wierd bug with fully qualified Carp::carp calls.
+
+0.01 Tue Nov 28 03:03:35 GMT 2000
+ - First working version released to CPAN.
+
+
diff --git a/MANIFEST b/MANIFEST
index f763a20..7bdbfc4 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,4 +1,7 @@
+Changes
MANIFEST
Makefile.PL
lib/Class/Virtual.pm
+lib/Class/Virtually/Abstract.pm
+t/Abstract.t
t/Virtual.t
diff --git a/Makefile.PL b/Makefile.PL
index 3d56540..b51e7ee 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -31,6 +31,7 @@ WriteMakefile(
PREREQ_PM => {
Class::Data::Inheritable => 0.02,
Class::ISA => 0.31,
+ Carp::Assert => 0.10,
},
'dist' => { COMPRESS => 'gzip -9',
SUFFIX => '.gz',
diff --git a/lib/Class/Virtual.pm b/lib/Class/Virtual.pm
index 09d4ca1..cc51669 100644
--- a/lib/Class/Virtual.pm
+++ b/lib/Class/Virtual.pm
@@ -2,8 +2,9 @@ package Class::Virtual;
use strict;
use vars qw($VERSION);
-$VERSION = '0.02';
+$VERSION = '0.03';
+use Carp::Assert;
use Class::ISA;
# Class::ISA doesn't export?!
*self_and_super_path = \&Class::ISA::self_and_super_path;
@@ -24,7 +25,7 @@ Class::Virtual - Base class for virtual base classes.
package My::Virtual::Idaho;
use base qw(Class::Virtual);
- __PACKAGE__->virtual_methods(new foo bar this that);
+ __PACKAGE__->virtual_methods(qw(new foo bar this that));
package My::Private::Idaho;
@@ -109,9 +110,9 @@ sub _mk_virtual_methods {
my($this_class, @methods) = @_;
$this_class->__Virtual_Methods(\@methods);
-
+
# private method to return the virtual base class
- *__virtual_base_class = sub {
+ *{$this_class.'::__virtual_base_class'} = sub {
return $this_class;
};
@@ -124,7 +125,7 @@ sub _mk_virtual_methods {
}
# Create a virtual method.
- *{$meth} = sub {
+ *{$this_class.'::'.$meth} = sub {
my($self) = shift;
my($class) = ref $self || $self;
@@ -140,7 +141,7 @@ sub _mk_virtual_methods {
}
};
}
-}
+}
=pod
@@ -165,6 +166,7 @@ sub missing_methods {
my $sclass;
do {
$sclass = pop @super_classes;
+ assert( defined $sclass ) if DEBUG;
} until $sclass eq $vclass;
my @missing = ();
@@ -189,12 +191,18 @@ sub missing_methods {
=head1 CAVEATS and BUGS
-Autoloaded methods are currently not recognized.
+Autoloaded methods are currently not recognized. I have no idea
+how to solve this.
=head1 AUTHOR
-Michael G Schwern <schwern at pobox.com>
+Michael G Schwern E<lt>schwern at pobox.comE<gt>
+
+
+=head1 SEE ALSO
+
+L<Class::Virtually::Abstract>
=cut
diff --git a/lib/Class/Virtually/Abstract.pm b/lib/Class/Virtually/Abstract.pm
new file mode 100644
index 0000000..a112263
--- /dev/null
+++ b/lib/Class/Virtually/Abstract.pm
@@ -0,0 +1,129 @@
+package Class::Virtually::Abstract;
+
+use strict;
+use base qw(Class::Virtual);
+use Carp::Assert;
+
+use vars qw(%Registered);
+
+{
+ no strict 'refs';
+
+ sub virtual_methods {
+ my($base_class) = shift;
+
+ if( @_ and !$Registered{$base_class} ) {
+ $Registered{$base_class} = 1;
+
+ my($has_orig_import) = 0;
+
+ # Shut up "subroutine import redefined"
+ local $^W = 0;
+
+ if( defined &{$base_class.'::import'} ) {
+ # Divert the existing import method.
+ $has_orig_import = 1;
+ *{$base_class.'::__orig_import'} = \&{$base_class.'::import'};
+ }
+
+ # We can't use a closure here, SUPER wouldn't work right. :(
+ eval <<"IMPORT";
+ package $base_class;
+
+ sub import {
+ my \$class = shift;
+ return if \$class eq '$base_class';
+
+ my \@missing_methods = \$class->missing_methods;
+ if (\@missing_methods) {
+ require Carp;
+ Carp::croak("Class \$class must define ".
+ join(', ', \@missing_methods).
+ " for class $base_class");
+ }
+
+ # Since import() is typically caller() sensitive, these
+ # must be gotos.
+ if( $has_orig_import ) {
+ goto &${base_class}::__orig_import;
+ }
+ elsif( my \$super_import = \$class->can('SUPER::import') ) {
+ goto &\$super_import;
+ }
+ }
+IMPORT
+
+ }
+
+ $base_class->SUPER::virtual_methods(@_);
+ }
+}
+
+1;
+
+
+=pod
+
+=head1 NAME
+
+Class::Virtually::Abstract - Compile-time enforcement of Class::Virtual
+
+
+=head1 SYNOPSIS
+
+ package My::Virtual::Idaho;
+ use base qw(Class::Virtually::Abstract);
+
+ __PACKAGE__->virtual_methods(qw(new foo bar this that));
+
+
+ package My::Private::Idaho;
+ use base qw(My::Virtual::Idaho);
+
+ sub new { ... }
+ sub foo { ... }
+ sub bar { ... }
+ sub this { ... }
+ # oops, forgot to implement that()!! Whatever will happen?!
+
+
+ # Meanwhile, in another piece of code!
+ # KA-BLAM! My::Private::Idaho fails to compile because it didn't
+ # fully implement My::Virtual::Idaho.
+ use My::Private::Idaho;
+
+=head1 DESCRIPTION
+
+This subclass of Class::Virtual provides B<compile-time> enforcement.
+That means subclasses of your virtual class are B<required> to
+implement all virtual methods or else it will not compile.
+
+
+=head1 BUGS and CAVEATS
+
+Because this relies on import() it is important that your classes are
+B<use>d instead of B<require>d. This is a problem, and I'm trying to
+figure a way around it.
+
+Also, if a subclass defines its own import() routine (why would a
+class need to export stuff? I've done it)
+Class::Virtually::Abstract's compile-time checking is defeated.
+
+Got to think of a better way to do this besides import().
+
+
+=head1 AUTHOR
+
+Original idea from Ben Tilly's AbstractClass
+http://www.perlmonks.org/index.pl?node_id=44300&lastnode_id=45341
+
+Embraced and Extended by Michael G Schwern E<lt>schwern at pobox.comE<gt>
+
+
+=head1 SEE ALSO
+
+L<Class::Virtual>
+
+=cut
+
+1;
diff --git a/t/Virtual.t b/t/Abstract.t
similarity index 58%
copy from t/Virtual.t
copy to t/Abstract.t
index c258020..354563e 100644
--- a/t/Virtual.t
+++ b/t/Abstract.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 Class::Virtual;
+use Class::Virtually::Abstract;
$loaded = 1;
ok(1, 'compile');
######################### End of black magic.
@@ -51,13 +51,13 @@ sub eqarray {
}
# Change this to your # of ok() calls + 1
-BEGIN { $Total_tests = 9 }
+BEGIN { $Total_tests = 16 }
my @vmeths = qw(new foo bar this that);
my $ok;
package Test::Virtual;
-use base qw(Class::Virtual);
+use base qw(Class::Virtually::Abstract);
__PACKAGE__->virtual_methods(@vmeths);
::ok( ::eqarray([sort __PACKAGE__->virtual_methods], [sort @vmeths]),
@@ -93,21 +93,66 @@ $ok = $@ =~ /^Attempt to reset virtual methods/;
::ok( $ok, "Disallow reseting by subclass" );
-### This test doesn't work and probably never will.
-###
-# package Test::That;
-# use base qw(Test::Virtual);
-
-# # Let's see how things work with an autoloader.
-# use vars qw($AUTOLOAD);
-# sub AUTOLOAD {
-# if( $AUTOLOAD =~ /(foo|bar)/ ) {
-# return "Yay!";
-# }
-# else {
-# die "ARrrrrrrrrrrgh!\n";
-# }
-# }
-
-# ::ok( ::eqarray([sort __PACKAGE__->missing_methods], [sort qw(new this that)]),
-# 'Autoloaded methods recognized' );
+package Test::Virtual::Again;
+use base qw(Class::Virtually::Abstract);
+__PACKAGE__->virtual_methods('bing');
+
+package Test::Again;
+use base qw(Test::Virtual::Again);
+::ok( ::eqarray([sort __PACKAGE__->virtual_methods], [sort qw(bing)] ),
+ 'Virtual classes not interfering' );
+::ok( ::eqarray([sort __PACKAGE__->missing_methods], [sort qw(bing)] ),
+ 'Missing methods not interfering' );
+
+::ok( ::eqarray([sort Test::This->virtual_methods], [sort @vmeths]),
+ 'Not overwriting virtual methods');
+::ok( ::eqarray([sort Test::This->missing_methods], [sort qw(new this that)]),
+ 'Not overwriting missing methods');
+
+eval {
+ Test::This->new;
+};
+::ok( $@ =~ /^Test::This forgot to implement new\(\) at/,
+ 'virtual method unimplemented, ok');
+
+eval {
+ Test::This->bing;
+};
+::ok( $@ =~ /^Can't locate object method "bing" via package "Test::This" at/,
+ 'virtual methods not leaking'); #')
+
+
+eval {
+ Test::Again->import;
+};
+::ok( $@ =~ /^Class Test::Again must define bing for class Test::Virtual::Again/ );
+
+package Test::More;
+use base qw(Test::Again);
+sub import { 42 }
+
+eval {
+ Test::More->import;
+};
+# ::ok( $@ =~ /^Class Test::More must define bing for class Test::Virtual::Again/ ); # TODO
+
+
+
+package Test::Yet::Again;
+use base qw(Class::Virtually::Abstract);
+__PACKAGE__->virtual_methods('foo');
+
+sub import {
+ $Test::Yet::Again = 42;
+}
+
+
+package Test::Yet;
+use base qw(Test::Yet::Again);
+
+sub foo { 23 }
+
+eval {
+ Test::Yet->import;
+};
+::ok( !$@ and $Test::Yet::Again == 42 );
diff --git a/t/Virtual.t b/t/Virtual.t
index c258020..bead3bf 100644
--- a/t/Virtual.t
+++ b/t/Virtual.t
@@ -51,7 +51,7 @@ sub eqarray {
}
# Change this to your # of ok() calls + 1
-BEGIN { $Total_tests = 9 }
+BEGIN { $Total_tests = 14 }
my @vmeths = qw(new foo bar this that);
my $ok;
@@ -93,6 +93,36 @@ $ok = $@ =~ /^Attempt to reset virtual methods/;
::ok( $ok, "Disallow reseting by subclass" );
+package Test::Virtual::Again;
+use base qw(Class::Virtual);
+__PACKAGE__->virtual_methods('bing');
+
+package Test::Again;
+use base qw(Test::Virtual::Again);
+::ok( ::eqarray([sort __PACKAGE__->virtual_methods], [sort qw(bing)] ),
+ 'Virtual classes not interfering' );
+::ok( ::eqarray([sort __PACKAGE__->missing_methods], [sort qw(bing)] ),
+ 'Missing methods not interfering' );
+
+::ok( ::eqarray([sort Test::This->virtual_methods], [sort @vmeths]),
+ 'Not overwriting virtual methods');
+::ok( ::eqarray([sort Test::This->missing_methods], [sort qw(new this that)]),
+ 'Not overwriting missing methods');
+
+eval {
+ Test::This->new;
+};
+::ok( $@ =~ /^Test::This forgot to implement new\(\) at/,
+ 'virtual method unimplemented, ok');
+
+eval {
+ Test::This->bing;
+};
+::ok( $@ =~ /^Can't locate object method "bing" via package "Test::This" at/,
+ 'virtual methods not leaking');
+
+
+
### This test doesn't work and probably never will.
###
# package Test::That;
--
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