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 <[email protected]> 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 <[email protected]> + +=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 _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
