cvsuser 01/11/29 15:46:38
Added: P5EEx/Beige/P5EEx/Beige ClassImplementor.pm ModuleTest.pm
ModuleTestDemo.pl
Log:
I'm a bit happier with this package. a much better building block. still lots to do
though.
Revision Changes Path
1.1 p5ee/P5EEx/Beige/P5EEx/Beige/ClassImplementor.pm
Index: ClassImplementor.pm
===================================================================
#!/usr/local/perl/bin
#
# Inline : methods declared in line with perl code.
# the class calling this code forms the object
# called.
#
# Dynamic : methods can be linked to at the run time.
# the class calling this class forms the
#
# Template : Similar in development style to Dynamic
# This defines methods that can be used
# as a child class
#
# Implementor : An implementor of a dynamic
# This specifies the code that is to be used
# the dynamic and implementor are linked on a first
# come first served basis
#
# Derived : This conforms to a given template. The class
# which is derived is called as a class in it's
# own right.
#
use strict;
package ClassImplementor;
{
my %classdata = (
ClassStore => {},
);
sub import
{
my $class = shift;
my %args = (
Mode => undef, # Can be
INLINE or DYNAMIC or IMPLEMENTOR or template
Target => undef, # The name of the
package that this implements
@_
);
# clean up namespace pollution from last import
my $pack = caller; # get calling package
die "Cannot Call from main\n" if ( $pack eq "main" || ! $pack );
die "Class Already Defined\n" if ( defined
${$classdata{ClassStore}}{$pack} );
# print $pack."\n";
# print @_;
$classdata{Scope} = $pack;
$classdata{Mode} = $args{Mode};
$classdata{Group} = $args{Group};
$classdata{MethodContext} = {};
for ( $args{Mode} )
{
/Inline/ && do {
no strict 'refs';
*{
join"::",($pack,"DeclareMethod") } = \&_DeclareMethodInline;
*{ join"::",($pack,"Object") }
= \&_Object;
*{ join"::",($pack,"Class") }
= \&_Class;
*{
join"::",($pack,"Subroutene") } = \&_Subroutene;
*{ join"::",($pack,"Object") }
= \&_Object;
*{ join"::",($pack,"Groups") }
= \&_Groups;
*{
join"::",($pack,"Arguments") } = \&_Arguments;
*{ join"::",($pack,"Rules") }
= \&_Rules;
*{ join"::",($pack,"Defaults")
} = \&_Defaults;
*{ join"::",($pack,"With") } =
\&_With;
${$classdata{ClassStore}}{$pack} = _ClassTemplate($pack);
last;
};
/Dynamic/ && do {
*{
join"::",($pack,"DeclareMethod") } = \&_DeclareMethodDynamic;
*{ join"::",($pack,"Object") }
= \&_Object;
*{ join"::",($pack,"Class") }
= \&_Class;
*{
join"::",($pack,"Subroutene") } = \&_Subroutene;
*{ join"::",($pack,"Object") }
= \&_Object;
*{ join"::",($pack,"Groups") }
= \&_Groups;
*{ join"::",($pack,"Rules") }
= \&_Rules;
*{
join"::",($pack,"Arguments") } = \&_Arguments;
*{ join"::",($pack,"Defaults")
} = \&_Defaults;
${$classdata{ClassStore}}{$pack} = _ClassTemplate($pack);
last;
};
/Implementor/ && do {
*{
join"::",($pack,"DeclareMethod") } = \&_DeclareMethodImplementor;
*{ join"::",($pack,"With") } =
\&_With;
last;
};
/Template/ && do {
*{
join"::",($pack,"DeclareMethod") } = \&_DeclareMethodTemplate;
*{ join"::",($pack,"Object") }
= \&_Object;
*{ join"::",($pack,"Class") }
= \&_Class;
*{
join"::",($pack,"Subroutene") } = \&_Subroutene;
*{ join"::",($pack,"Object") }
= \&_Object;
*{ join"::",($pack,"Groups") }
= \&_Groups;
*{ join"::",($pack,"Rules") }
= \&_Rules;
*{
join"::",($pack,"Arguments") } = \&_Arguments;
*{ join"::",($pack,"Defaults")
} = \&_Defaults;
${$classdata{ClassStore}}{$pack} = _ClassTemplate($pack);
last;
};
/Derived/ && do {
*{
join"::",($pack,"DeclareMethod") } = \&_DeclareMethodDerived;
*{ join"::",($pack,"With") } =
\&_With;
last;
};
die "Not Recognised\n";
};
};
sub _ClassTemplate # defines a class for a template
{
return {
Type => shift,
Methods => undef,
};
}
sub _DeclareMethodInline # declares a method declaration for inline
code
{
my $name = shift;
my $ptr = $classdata{MethodContext};
my $pack = caller;
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
die "Attempt to redefine Method\n" if ( exists
${${$classdata{MethodContext}}{Methods}}{$name} );
die "Accessor Not Defined\n" unless ( defined $ptr -> {Caller} );
# define Accessor test
my $acctest;
for ( $ptr -> {Caller} )
{
my $m = ' my ($m,%a) = @_;';
/^Object$/ && do {
$acctest = $m;
$acctest .= 'die "Must
be called by object\n" unless ( ref $m eq "'.$pack.'" );';
last;
};
/^Class$/ && do {
$acctest = $m;
$acctest .= 'die "Must
be called by class\n" unless ( $m eq "'.$pack.'" );';
last;
};
/^Sunroutene$/ && do {
$acctest = 'my $m;my
(%a) = @_;';
last;
};
/^Method$/ && do {
$acctest = $m;
$acctest .= 'die "Must
be called as method\n" unless ( $m eq "'.$pack.'" | ref $m eq "'.$pack.'" );';
last;
};
die "Bad accessor";
};
# Ensure defaults, if defined are present in arguments
if ( ref $ptr -> {Defaults} eq "HASH" )
{
while ( my ($k,$v) = each %{ $ptr -> {Defaults} } )
{
die "Default defined for invalid argument\n" unless (
exists ${ $ptr -> {Arguments} }{$k} );
${ $ptr -> {Arguments} }{ $k } = $v;
};
};
# Ensure rules, if defined are in present in arguments
if ( ref $ptr -> {Rules} eq "HASH" )
{
while ( my ($k,$v) = each %{ $ptr -> {Rules} } )
{
die "Rule defined for invalid argument\n" unless (
exists ${ $ptr -> {Arguments} }{$k} );
};
};
# Argument Test
my $argtest;
if ( ref $ptr -> {Arguments} eq "HASH" && keys %{ $ptr -> {Arguments}
} )
{
# copy in defaults
$argtest = '%a = (('.(join ",",map { "'".$_."'" } ( %{$ptr ->
{Arguments}} )).'),%a);';
# Ensure correct number of arguments passed
$argtest .= 'die "Bad Arguments\n" unless ( scalar keys (%a)
== '.scalar keys (%{ $ptr -> {Arguments} }).' );';
# check against rules
# and recreate @_
$argtest .= '@_ = ( defined $m ? ($m,(%a) ) : (%a) );';
}
else
{
$argtest = 'die "Arguments Not permitted\n" if ( scalar keys
%a );';
}
${${$classdata{MethodContext}}{Methods}}{$name} = $ptr;
{
my $sub = eval
'sub { '.
$acctest.
$argtest.
'goto
${${$classdata{MethodContext}}{Methods}}{'.$name.'}->{Code} };';
if ( $@ )
{
die "Cannot Create Linking subroutene\n";
}
no strict 'refs';
*{ join "::",($classdata{Scope}, $name) } = $sub;
}
};
sub _DeclareMethodDynamic; # declares a method declaration for
dynamic code
{
};
sub _DeclareMethodImplementor; # declares a method declaration for inline
code
{
};
sub _DeclareMethodTemplate; # declares a method declaration for inline
code
{
};
sub _DeclareMethodDerived; # declares a method declaration for inline
code
{
};
sub _Object() # Returns "Object" for nice syntax
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Caller} = "Object";
};
sub _Class() # Returns "Class" for nice syntax
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Caller} = "Class";
};
sub _Subroutene() # Returns "Subroutene" for nice syntax
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Caller} = "Class";
};
sub _Method() # Returns "Method" for nice syntax
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Caller} = "Method";
};
sub _Arguments(@) # Takes in a list, returns a hash ref
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Arguments} = {};
map { $ptr -> {Arguments} -> { $_ } = undef } @_;
};
sub _Rules (@)
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Rules} = {@_};
}
sub _Defaults(@) # Takes in a list, returns a hash ref
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Defaults} = {@_};
};
sub _Groups(@) # Takes in groups, returns an array ref
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Groups} = [@_];
};
sub _With(&) # takes in code, returns ref to sub
{
my $pack = caller; # get calling package
die "Attempt to define module outside of scope\n" unless (
$classdata{Scope} eq $pack );
my $ptr = $classdata{MethodContext};
$ptr -> {Code} = shift;
};
};
1;
1.1 p5ee/P5EEx/Beige/P5EEx/Beige/ModuleTest.pm
Index: ModuleTest.pm
===================================================================
#!/usr/local/perl/bin
# Hello.
package ModuleTest;
print "fred";
sub import
{
# my $pack = (caller(0))[0];
my $pack = caller;
print "dOUG";
print $pack;
print keys %{ $pack."::" };
*{ $pack."::TestSub" } = sub { print "hello" };
#*{${ $pack."::" }}{TestSub} = sub { print "Hello" };
#*{{$pack."::"}}{"TestSub"} = sub { print "Hello" };
return 1;
};
1;
1.1 p5ee/P5EEx/Beige/P5EEx/Beige/ModuleTestDemo.pl
Index: ModuleTestDemo.pl
===================================================================
#!/usr/local/perl/bin
use ModuleTestDemo;
'ModuleTestDemo' -> TestSub();
<STDIN>;
1;
