cvsuser 01/11/22 14:33:35
Modified: P5EEx/Beige/P5EEx README
Added: P5EEx/Beige/P5EEx/Beige/Registry ClassRegistery.pm
P5EEx/Beige/P5EEx/Beige/Security CallerDependentHash.pm
PublicPrivateMethods.pm
Log:
Added a few files - read readme for details.
This is a very premature release. Apologies
Revision Changes Path
1.2 +28 -0 p5ee/P5EEx/Beige/P5EEx/README
Index: README
===================================================================
RCS file: /cvs/public/p5ee/P5EEx/Beige/P5EEx/README,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- README 2001/11/20 20:16:03 1.1
+++ README 2001/11/22 22:33:34 1.2
@@ -11,5 +11,33 @@
I've seen class::fields but I may be taking this in a
slightly different direction.
+*------------ New Files --------------*
+
+I've added a few files here.
+
+They contain a few large errors, but may assist
+in explaining the direction that I wish to go with this.
+( I'm not even sure if the registry stuff compiles )
+
+Basically - the short term future will involve fixing
+bugs, bringing the whole thing together in a package,
+and making sure that the dependant hash, and publicprivate
+methods interface correctly with the registry 'object',
+this together with making public private import it's new
+method should lead to a nicer environment.
+
+Although this has been developed seperate from Stephen
+Atkins blue project, it appears to be reasonably
+complementry. This fact, together with a few issues
+that are arising from other sources lead me to what
+is quite obviously a premature commit to the repository.
+
+Therefore I'll leave of declaring this on the group until
+it's a stable release
+
+I do hope you'll forgive me, comments as always,
+will be much appreciatted.
+
+Cheers,
Steve.
1.1 p5ee/P5EEx/Beige/P5EEx/Beige/Registry/ClassRegistery.pm
Index: ClassRegistery.pm
===================================================================
package ClassRegistry;
=head1 NAME
(P5EEx::Biege) Class Registry
=head1 DESCRIPTION
This is intended to allow classes to be registered
in a central reposistory
This will provide a few key features:
=head2 Register a class with a purpose
As perl is all about TMTOWTDI, it's probable that
a number of classes can be created to serve a similar
purpose.
This allows the choice of a particular class to be a
configuration rather than a programming model.
=head2 Register a class as a member of a group.
This is best illustrated by an example.
One of my bug bears with programmers is that
beginners will put print statements in objects that
could never be in an environment where it is desirable
to print from - i.e in a cgi-script before the
Content-Type Tag has been issued.
In Order to help facilitate a few more barriers,
It's nice to segregate objects into groups.
=head2 Register a Method with accessing groups
This takes the public/private thing one step futher,
and I can't resist a slight analogy.
Just because you work with someone doesn't emply you
want to drink with them, or go even further...
Likewise, whilst you may allow any object to check
for the existence of a file, you wouldn't necessarily
want any old perl fragment to be able to delete it.
=head2 Register a Method with named arguments.
Whilst you can have named arguments in perl:
my %args = (
Arg1 => undef,
Arg2 => undef,
@_
);
It's incredibly easy to implement this in perl,
and unfortunately it's also easy to call the
wrong stored procedure with the wrong arguments
For example, whilst still in my early days of perl
programming, I wrote the something like following:
prunk ( Roger => "Hello World" );
sub prunk
{
my %args=(
Rodger => undef,
@_
);
print $args{Rodger};
}
And it took me a wee while to find out the cause
of the error.
And finally, yes, it is slower, but hey, it looks
so much clearer. and programmers can sometimes be more
expensive than CPU or memory...
=head2 Lock The Registry
Otherwise some smart arse will just modify the
attributes of the particular module he wants to call
in order to allow him access.
Sod's law. Hopefully by the time they have the time
to break the finalised version, they will have learnt
why they shouldn't.
Unless of course they are bad people.
=head1 Methods
=cut
{
my $object = bless {};
$object -> {NextGroup} = 0;
$object -> Purpose = {};
$object -> Groups = {Default => {
ID => $object -> {NextGroup}++,
Description => 'Default group'
};
=head2 GenerateGroup
You need to generate a group before you can define
it on a class. A default group, 'Default' is provided.
Usage:
my $id = bob;
ClassRegistry::GenerateGroup(
Name => "Sue",
Description => 'A group called Sue.',
GroupId => \$id
);
=cut
sub GenerateGroup
{
die "Object Locked\n" if ( defined $object -> {Lock} );
my %args = (
Name => undef,
Description => 'A badly defined group.',
@_
);
die "Bad Generation Attempt\n" unless (
defined $args{Name}
);
die "Attempt To Regenerate Group\n" if (
exists $object -> {Groups} -> { $args{Name} }
);
my $t = $object -> {NextGroup}++;
$object -> {Groups} -> { $args{Name} } = {
Description => "".$args{Description},
ID => $t,
};
};
=head2 RegisterClass
Registers a class's purpose, and it's group
Usage:
ClassRegistry::RegisterPurpose (
Class => "Example::Package",
Purpose => "Purpose::Of::Package",
Group => "Sue"
);
=cut
sub RegisterPurpose
{
die "Object Locked\n" if ( defined $object -> {Lock} );
my %args = (
Class => undef,
Purpose => undef,
Group => 0,
@_
);
die "Bad Group\n" unless ( exists ${$object -> {Groups}}{ $args{Group} } );
$object -> {Purpose} -> {$args{Purpose}} =
{
Class => $args{Class},
Group => ${ $object -> {Groups} -> {$args{Group}} }{ID}
};
};
=head2 Lock
Usage:
ClassRegistry::Lock();
Locks the registry so that no more modifications can be made.
=cut
sub Lock
{
$object -> {Lock} = 1;
};
=head2 RegisterMethod
Registers a Method with a set of arguments,
with validation and accessing groups.
Usage:
ClassRegistry::RegisterMethod(
Purpose => 'Purpose::Of::Package',
Method => 'MethodName',
Arguments => {
Argument1 => 'ref $_ eq "HASH"',
Argument2 => "! ref $_",
Argument3 => "( ref $_ eq 'Hash' || ref $_ eq 'Array' )",
},
Groups => ['Sue'],
);
I really need to make this more efficient. Recomendations welcome.
I didn't want to put much effort into any of this as it's an expirement.
=cut
sub RegisterMethod
{
die "Object Locked\n" if ( defined $object -> {Lock} );
my %args = (
Purpose => undef,
Method => undef,
Arguments => {},
Groups => [],
@_
);
die "Bad Purpose\n" unless ( exists $object -> {Purpose} -> {$args{Purpose}}
);
die "No method\n" unless ( defined ref $args{Method} );
die "Bad Arguments\n" unless ( ref $args{Arguments} eq "HASH" );
die "Bad Groups\n" unless ( ref $args{Groups} eq "ARRAY" );
die "Method Already Exists\n" if ( exists ${ $object -> {Purpose} ->
{$args{Purpose}} }{Methods} );
my %groups;
map {
(
defined ( my $g = ${}{$_} ) ?
$groups{ ${ $object -> {Groups} -> {$_} }{ID} } = undef :
die "Bad Group".$_;
)
} @{$args{Groups}};
# Generate subroutene to validate arguments
my $sub =
eval
"
sub {
my %h = ("
.join ',',(map { $_." => " undef } keys %{ $args{Argument} } ) #
copy in arguments
.",@_);
die \"BadArguments\n\" unless ( scalar ( keys %h ) eq
".scalar(keys %{ $args{Argument} })." );
".
# Heres where field validation takes place
join '',( map {
'for ( $h{'.$_.'} ){ die "Argument Invalid :'.$_.'\n" unless
'.
${ $args{Arguments} }{$_}.'; };'
} keys %{ $args{Arguments} } )
."
};
";
die "Cannot Generate Subroutene\n" if ( $@ );
# And place subroutene and groups into object data
${ $object -> {Purpose} -> {$args{Purpose}} }{Methods} = {
Groups => \%groups,
Validate => $sub
};
};
=head2 CanCall
This tests to see if a given purpose can call a method
belonging to another purpose.
=cut
sub CanCall
{
my %args = (
CallingPurpose => undef,
Purpose => undef,
Method => undef,
Arguments => {},
@_
);
die "Calling Purpose does not exist\n " unless ( exists $object ->
{Groups} -> { $args{CallingPurpose} } );
die "Purpose does not exist\n" unless ( exists $object -> {Groups} ->
{ $args{CallingPurpose} } );
die "Method does not exist\n" unless ( exists ${ $object -> {Purpose}
-> {$args{Purpose}} }{Methods} );
die "Permission denied on object\n" unless ( exists $object ->
{Purpose} -> {$args{Purpose}} } -> {Methods} -> {Groups} ->
{ $object -> {Groups} -> {
$args{CallingPurpose} } -> {ID} } )
&{$object -> {Purpose} -> {$args{Purpose}} } -> {Methods} -> {Groups}
-> {Validate} }( %{ $args{Arguments} } );
return 1;
};
};
=head1 TODO
This isn't my final opinion on the subject, just the
my current opinion. I'll end up kicking and cursing
myself later.
Wouldn't mind adding some sort of error repository also.
And it's a first cut. I'm sure there are beter techniques
which can be used to achieve the same purpose. The means
of using this to generate could also do with some work.
=cut
'The green teletubby is an underated charactor actor, IMHO';
1.1 p5ee/P5EEx/Beige/P5EEx/Beige/Security/CallerDependentHash.pm
Index: CallerDependentHash.pm
===================================================================
#!/usr/local/bin/perl
=pod
=head1 NAME
P5EEx::Biege::Security::CallerDependentHash;
=head1 DESCRIPTION
This creates a tied hash which behaves quite
like a normal hash with two key exceptions.
The first is that a list of classes must
be specified in order to tie the package.
The second is that the hash is visible
only to the class that begat it.
Each of the different classes see a different
view of the hash.
=head1 METHODS
Everything you would expect to be in a normal
hash really.
=cut
use strict;
package Security::CallerDependentHash;
sub TIEHASH
{
my $class = shift;
my %args = (
AccessClass => undef,
@_
);
my %access;
if ( ref $args{AccessClass} eq "ARRAY" )
{
map { $access{"".$_} = {} } @{ $args{AccessClass} };
}
elsif ( ! ref $args{AccessClass} && length $args{AccessClass} )
{
$access{ $args{AccessClass} } = {};
}
else
{
die "ILLEGALACCESSCLASS";
}
my $obj = {
AccessClass => \%access
};
return bless $obj,$class;
};
sub FETCH
{
my $self = shift;
my $key = shift;
die "ILLEGALFETCH\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
return ${ $self -> {AccessClass} } { $key };
};
sub STORE
{
my $self = shift;
my $key = shift;
my $value = shift;
die "ILLEGALSTORE\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
${ $self -> {AccessClass} } { $key } = $value;
};
sub DELETE
{
my $self = shift;
my $key = shift;
die "ILLEGALDELETE\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
delete ${ $self -> {AccessClass} } { $key };
};
sub CLEAR
{
my $self = shift;
die "ILLEGALCLEAR\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
$self -> {AccessClass} = {};
};
sub EXISTS
{
my $self = shift;
my $key = shift;
die "ILLEGALEXISTS\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
return exists ${ $self -> {AccessClass} } { $key };
};
sub FIRSTKEY
{
my $self = shift;
die "ILLEGALFIRSTKEY\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
scalar keys %{ $self -> {AccessClass} };
return scalar each %{ $self -> {AccessClass} } ;
};
sub NEXTKEY
{
my $self = shift;
die "ILLEGALNEXTKEY\n" unless ( exists ${ $self -> {AccessClass} }{ ( caller
)[0] } );
return scalar each %{ $self -> {AccessClass} } ;
};
sub DESTROY
{
};
1;
1.1 p5ee/P5EEx/Beige/P5EEx/Beige/Security/PublicPrivateMethods.pm
Index: PublicPrivateMethods.pm
===================================================================
#!/usr/local/bin/perl
=pod
=head1 NAME
P5EEx::Biege::Security::PublicPrivateMethods;
=head1 DESCRIPTION
A wee play around with implementing a public/private
method framework in perl.
This ones really simple. It simply allows the user to
create an instance of a given class, and to define
public methods. Any methods not defined as public are
taken to be private.
=head1 METHODS
Well at the moment there is two really.
new() creates a new instance of a class, and requires
the ClassName of the object( together with a list of
publicly available methods, in order to make
it usefull ).
can() allows code to test wether it has permission to
call a method on a given class.
Anything else is taken to be a call to the object
invoked.
=cut
use strict;
use Security::CallerDependentHash;
package Security::PublicPrivateMethods;
sub new
{
my $class = shift;
my %args = (
InstanceRealm => undef,
ClassName => undef,
PublicMethods => {},
@_
);
die "BAD DECLARATION OF PUBLIC METHODS\n" unless ( ref $args{PublicMethods} eq
"ARRAY" );
if ( ref $args{InstanceRealm} eq "SCALAR" && defined ${ $args{InstanceRealm} }
)
{
return ${ $args{InstanceRealm} }; # Job Done
}
# Generate Container
my $self = {};
tie %{$self},'Security::CallerDependentHash',
(
AccessClass => [$class,$args{ClassName}]
);
$self -> {Object} = bless {},$args{ClassName};
# Copy in Public Methods
$self -> {PublicMethods} = {};
map { ${$self -> {PublicMethods}}{$_} = undef } @{ $args{PublicMethods} };
# ClassName of object might be nice to store
$self -> {ClassName} = $args{ClassName};
# And generate and return object
my $handler = bless $self,$class;
if ( ref $args{InstanceRealm} eq "SCALAR" )
{
${ $args{InstanceRealm} } = $handler; # Job Done
}
return $handler;
};
sub DESTROY # To prevent AUTOLOAD
{
my $self = shift;
delete $self -> {Object};
};
sub can
{
my $self = shift;
my $method = shift;
return $self -> {Object} -> can($method) &&
( ( caller )[0] eq $self -> {ClassName} ||
exists ${ ${$self}{PublicMethods} }{$method}
);
}
sub AUTOLOAD
{
my $self = shift;
my $method;
{
no strict 'vars';
$method = $AUTOLOAD;
$method =~ s/.*:://;
}
# What is the context?
if ( ( caller )[0] eq $self -> {ClassName} )
{
return $self -> {Object} -> $method( @_ );
}
else # Call public methods only
{
if ( exists ${ ${$self}{PublicMethods} }{$method} )
{
return $self -> {Object} -> $method ( @_);
}
else
{
die "Illegal Method : ".$method." , from Package:".( caller
)[0]."\n";
}
};
};
1;
