mirror of
https://github.com/vincentmli/bpfire.git
synced 2026-04-28 11:43:25 +02:00
Finalized core13 and redirector fixes
Added some files to core14 First Beta of MPFire V3
This commit is contained in:
Christian Schmidt
675
config/mpfire/perl/Accessor.pm
Executable file
675
config/mpfire/perl/Accessor.pm
Executable file
@@ -0,0 +1,675 @@
|
||||
package Class::Accessor;
|
||||
require 5.00502;
|
||||
use strict;
|
||||
$Class::Accessor::VERSION = '0.31';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Class::Accessor - Automated accessor generation
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Employee;
|
||||
use base qw(Class::Accessor);
|
||||
Employee->mk_accessors(qw(name role salary));
|
||||
|
||||
# Meanwhile, in a nearby piece of code!
|
||||
# Class::Accessor provides new().
|
||||
my $mp = Foo->new({ name => "Marty", role => "JAPH" });
|
||||
|
||||
my $job = $mp->role; # gets $mp->{role}
|
||||
$mp->salary(400000); # sets $mp->{salary} = 400000 (I wish)
|
||||
|
||||
# like my @info = @{$mp}{qw(name role)}
|
||||
my @info = $mp->get(qw(name role));
|
||||
|
||||
# $mp->{salary} = 400000
|
||||
$mp->set('salary', 400000);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module automagically generates accessors/mutators for your class.
|
||||
|
||||
Most of the time, writing accessors is an exercise in cutting and
|
||||
pasting. You usually wind up with a series of methods like this:
|
||||
|
||||
sub name {
|
||||
my $self = shift;
|
||||
if(@_) {
|
||||
$self->{name} = $_[0];
|
||||
}
|
||||
return $self->{name};
|
||||
}
|
||||
|
||||
sub salary {
|
||||
my $self = shift;
|
||||
if(@_) {
|
||||
$self->{salary} = $_[0];
|
||||
}
|
||||
return $self->{salary};
|
||||
}
|
||||
|
||||
# etc...
|
||||
|
||||
One for each piece of data in your object. While some will be unique,
|
||||
doing value checks and special storage tricks, most will simply be
|
||||
exercises in repetition. Not only is it Bad Style to have a bunch of
|
||||
repetitious code, but its also simply not lazy, which is the real
|
||||
tragedy.
|
||||
|
||||
If you make your module a subclass of Class::Accessor and declare your
|
||||
accessor fields with mk_accessors() then you'll find yourself with a
|
||||
set of automatically generated accessors which can even be
|
||||
customized!
|
||||
|
||||
The basic set up is very simple:
|
||||
|
||||
package My::Class;
|
||||
use base qw(Class::Accessor);
|
||||
My::Class->mk_accessors( qw(foo bar car) );
|
||||
|
||||
Done. My::Class now has simple foo(), bar() and car() accessors
|
||||
defined.
|
||||
|
||||
=head2 What Makes This Different?
|
||||
|
||||
What makes this module special compared to all the other method
|
||||
generating modules (L<"SEE ALSO">)? By overriding the get() and set()
|
||||
methods you can alter the behavior of the accessors class-wide. Also,
|
||||
the accessors are implemented as closures which should cost a bit less
|
||||
memory than most other solutions which generate a new method for each
|
||||
accessor.
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
my $obj = Class->new;
|
||||
my $obj = $other_obj->new;
|
||||
|
||||
my $obj = Class->new(\%fields);
|
||||
my $obj = $other_obj->new(\%fields);
|
||||
|
||||
Class::Accessor provides a basic constructor. It generates a
|
||||
hash-based object and can be called as either a class method or an
|
||||
object method.
|
||||
|
||||
It takes an optional %fields hash which is used to initialize the
|
||||
object (handy if you use read-only accessors). The fields of the hash
|
||||
correspond to the names of your accessors, so...
|
||||
|
||||
package Foo;
|
||||
use base qw(Class::Accessor);
|
||||
Foo->mk_accessors('foo');
|
||||
|
||||
my $obj = Class->new({ foo => 42 });
|
||||
print $obj->foo; # 42
|
||||
|
||||
however %fields can contain anything, new() will shove them all into
|
||||
your object. Don't like it? Override it.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my($proto, $fields) = @_;
|
||||
my($class) = ref $proto || $proto;
|
||||
|
||||
$fields = {} unless defined $fields;
|
||||
|
||||
# make a copy of $fields.
|
||||
bless {%$fields}, $class;
|
||||
}
|
||||
|
||||
=head2 mk_accessors
|
||||
|
||||
Class->mk_accessors(@fields);
|
||||
|
||||
This creates accessor/mutator methods for each named field given in
|
||||
@fields. Foreach field in @fields it will generate two accessors.
|
||||
One called "field()" and the other called "_field_accessor()". For
|
||||
example:
|
||||
|
||||
# Generates foo(), _foo_accessor(), bar() and _bar_accessor().
|
||||
Class->mk_accessors(qw(foo bar));
|
||||
|
||||
See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
|
||||
for details.
|
||||
|
||||
=cut
|
||||
|
||||
sub mk_accessors {
|
||||
my($self, @fields) = @_;
|
||||
|
||||
$self->_mk_accessors('rw', @fields);
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
no strict 'refs';
|
||||
|
||||
sub _mk_accessors {
|
||||
my($self, $access, @fields) = @_;
|
||||
my $class = ref $self || $self;
|
||||
my $ra = $access eq 'rw' || $access eq 'ro';
|
||||
my $wa = $access eq 'rw' || $access eq 'wo';
|
||||
|
||||
foreach my $field (@fields) {
|
||||
my $accessor_name = $self->accessor_name_for($field);
|
||||
my $mutator_name = $self->mutator_name_for($field);
|
||||
if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
|
||||
$self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
|
||||
}
|
||||
if ($accessor_name eq $mutator_name) {
|
||||
my $accessor;
|
||||
if ($ra && $wa) {
|
||||
$accessor = $self->make_accessor($field);
|
||||
} elsif ($ra) {
|
||||
$accessor = $self->make_ro_accessor($field);
|
||||
} else {
|
||||
$accessor = $self->make_wo_accessor($field);
|
||||
}
|
||||
unless (defined &{"${class}::$accessor_name"}) {
|
||||
*{"${class}::$accessor_name"} = $accessor;
|
||||
}
|
||||
if ($accessor_name eq $field) {
|
||||
# the old behaviour
|
||||
my $alias = "_${field}_accessor";
|
||||
*{"${class}::$alias"} = $accessor unless defined &{"${class}::$alias"};
|
||||
}
|
||||
} else {
|
||||
if ($ra and not defined &{"${class}::$accessor_name"}) {
|
||||
*{"${class}::$accessor_name"} = $self->make_ro_accessor($field);
|
||||
}
|
||||
if ($wa and not defined &{"${class}::$mutator_name"}) {
|
||||
*{"${class}::$mutator_name"} = $self->make_wo_accessor($field);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub follow_best_practice {
|
||||
my($self) = @_;
|
||||
my $class = ref $self || $self;
|
||||
*{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
|
||||
*{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
=head2 mk_ro_accessors
|
||||
|
||||
Class->mk_ro_accessors(@read_only_fields);
|
||||
|
||||
Same as mk_accessors() except it will generate read-only accessors
|
||||
(ie. true accessors). If you attempt to set a value with these
|
||||
accessors it will throw an exception. It only uses get() and not
|
||||
set().
|
||||
|
||||
package Foo;
|
||||
use base qw(Class::Accessor);
|
||||
Class->mk_ro_accessors(qw(foo bar));
|
||||
|
||||
# Let's assume we have an object $foo of class Foo...
|
||||
print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
|
||||
$foo->foo(42); # BOOM! Naughty you.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub mk_ro_accessors {
|
||||
my($self, @fields) = @_;
|
||||
|
||||
$self->_mk_accessors('ro', @fields);
|
||||
}
|
||||
|
||||
=head2 mk_wo_accessors
|
||||
|
||||
Class->mk_wo_accessors(@write_only_fields);
|
||||
|
||||
Same as mk_accessors() except it will generate write-only accessors
|
||||
(ie. mutators). If you attempt to read a value with these accessors
|
||||
it will throw an exception. It only uses set() and not get().
|
||||
|
||||
B<NOTE> I'm not entirely sure why this is useful, but I'm sure someone
|
||||
will need it. If you've found a use, let me know. Right now its here
|
||||
for orthoginality and because its easy to implement.
|
||||
|
||||
package Foo;
|
||||
use base qw(Class::Accessor);
|
||||
Class->mk_wo_accessors(qw(foo bar));
|
||||
|
||||
# Let's assume we have an object $foo of class Foo...
|
||||
$foo->foo(42); # OK. Sets $self->{foo} = 42
|
||||
print $foo->foo; # BOOM! Can't read from this accessor.
|
||||
|
||||
=cut
|
||||
|
||||
sub mk_wo_accessors {
|
||||
my($self, @fields) = @_;
|
||||
|
||||
$self->_mk_accessors('wo', @fields);
|
||||
}
|
||||
|
||||
=head1 DETAILS
|
||||
|
||||
An accessor generated by Class::Accessor looks something like
|
||||
this:
|
||||
|
||||
# Your foo may vary.
|
||||
sub foo {
|
||||
my($self) = shift;
|
||||
if(@_) { # set
|
||||
return $self->set('foo', @_);
|
||||
}
|
||||
else {
|
||||
return $self->get('foo');
|
||||
}
|
||||
}
|
||||
|
||||
Very simple. All it does is determine if you're wanting to set a
|
||||
value or get a value and calls the appropriate method.
|
||||
Class::Accessor provides default get() and set() methods which
|
||||
your class can override. They're detailed later.
|
||||
|
||||
=head2 follow_best_practice
|
||||
|
||||
In Damian's Perl Best Practices book he recommends separate get and set methods
|
||||
with the prefix set_ and get_ to make it explicit what you intend to do. If you
|
||||
want to create those accessor methods instead of the default ones, call:
|
||||
|
||||
__PACKAGE__->follow_best_practice
|
||||
|
||||
=head2 accessor_name_for / mutator_name_for
|
||||
|
||||
You may have your own crazy ideas for the names of the accessors, so you can
|
||||
make those happen by overriding C<accessor_name_for> and C<mutator_name_for> in
|
||||
your subclass. (I copied that idea from Class::DBI.)
|
||||
|
||||
=cut
|
||||
|
||||
sub best_practice_accessor_name_for {
|
||||
my ($class, $field) = @_;
|
||||
return "get_$field";
|
||||
}
|
||||
|
||||
sub best_practice_mutator_name_for {
|
||||
my ($class, $field) = @_;
|
||||
return "set_$field";
|
||||
}
|
||||
|
||||
sub accessor_name_for {
|
||||
my ($class, $field) = @_;
|
||||
return $field;
|
||||
}
|
||||
|
||||
sub mutator_name_for {
|
||||
my ($class, $field) = @_;
|
||||
return $field;
|
||||
}
|
||||
|
||||
=head2 Modifying the behavior of the accessor
|
||||
|
||||
Rather than actually modifying the accessor itself, it is much more
|
||||
sensible to simply override the two key methods which the accessor
|
||||
calls. Namely set() and get().
|
||||
|
||||
If you -really- want to, you can override make_accessor().
|
||||
|
||||
=head2 set
|
||||
|
||||
$obj->set($key, $value);
|
||||
$obj->set($key, @values);
|
||||
|
||||
set() defines how generally one stores data in the object.
|
||||
|
||||
override this method to change how data is stored by your accessors.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my($self, $key) = splice(@_, 0, 2);
|
||||
|
||||
if(@_ == 1) {
|
||||
$self->{$key} = $_[0];
|
||||
}
|
||||
elsif(@_ > 1) {
|
||||
$self->{$key} = [@_];
|
||||
}
|
||||
else {
|
||||
$self->_croak("Wrong number of arguments received");
|
||||
}
|
||||
}
|
||||
|
||||
=head2 get
|
||||
|
||||
$value = $obj->get($key);
|
||||
@values = $obj->get(@keys);
|
||||
|
||||
get() defines how data is retreived from your objects.
|
||||
|
||||
override this method to change how it is retreived.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
|
||||
if(@_ == 1) {
|
||||
return $self->{$_[0]};
|
||||
}
|
||||
elsif( @_ > 1 ) {
|
||||
return @{$self}{@_};
|
||||
}
|
||||
else {
|
||||
$self->_croak("Wrong number of arguments received");
|
||||
}
|
||||
}
|
||||
|
||||
=head2 make_accessor
|
||||
|
||||
$accessor = Class->make_accessor($field);
|
||||
|
||||
Generates a subroutine reference which acts as an accessor for the given
|
||||
$field. It calls get() and set().
|
||||
|
||||
If you wish to change the behavior of your accessors, try overriding
|
||||
get() and set() before you start mucking with make_accessor().
|
||||
|
||||
=cut
|
||||
|
||||
sub make_accessor {
|
||||
my ($class, $field) = @_;
|
||||
|
||||
# Build a closure around $field.
|
||||
return sub {
|
||||
my $self = shift;
|
||||
|
||||
if(@_) {
|
||||
return $self->set($field, @_);
|
||||
}
|
||||
else {
|
||||
return $self->get($field);
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
=head2 make_ro_accessor
|
||||
|
||||
$read_only_accessor = Class->make_ro_accessor($field);
|
||||
|
||||
Generates a subroutine refrence which acts as a read-only accessor for
|
||||
the given $field. It only calls get().
|
||||
|
||||
Override get() to change the behavior of your accessors.
|
||||
|
||||
=cut
|
||||
|
||||
sub make_ro_accessor {
|
||||
my($class, $field) = @_;
|
||||
|
||||
return sub {
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
my $caller = caller;
|
||||
$self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
|
||||
}
|
||||
else {
|
||||
return $self->get($field);
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
=head2 make_wo_accessor
|
||||
|
||||
$read_only_accessor = Class->make_wo_accessor($field);
|
||||
|
||||
Generates a subroutine refrence which acts as a write-only accessor
|
||||
(mutator) for the given $field. It only calls set().
|
||||
|
||||
Override set() to change the behavior of your accessors.
|
||||
|
||||
=cut
|
||||
|
||||
sub make_wo_accessor {
|
||||
my($class, $field) = @_;
|
||||
|
||||
return sub {
|
||||
my $self = shift;
|
||||
|
||||
unless (@_) {
|
||||
my $caller = caller;
|
||||
$self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
|
||||
}
|
||||
else {
|
||||
return $self->set($field, @_);
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
=head1 EXCEPTIONS
|
||||
|
||||
If something goes wrong Class::Accessor will warn or die by calling Carp::carp
|
||||
or Carp::croak. If you don't like this you can override _carp() and _croak() in
|
||||
your subclass and do whatever else you want.
|
||||
|
||||
=cut
|
||||
|
||||
use Carp ();
|
||||
|
||||
sub _carp {
|
||||
my ($self, $msg) = @_;
|
||||
Carp::carp($msg || $self);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _croak {
|
||||
my ($self, $msg) = @_;
|
||||
Carp::croak($msg || $self);
|
||||
return;
|
||||
}
|
||||
|
||||
=head1 EFFICIENCY
|
||||
|
||||
Class::Accessor does not employ an autoloader, thus it is much faster
|
||||
than you'd think. Its generated methods incur no special penalty over
|
||||
ones you'd write yourself.
|
||||
|
||||
accessors:
|
||||
Rate Basic Average Fast Faster Direct
|
||||
Basic 189150/s -- -42% -51% -55% -89%
|
||||
Average 327679/s 73% -- -16% -22% -82%
|
||||
Fast 389212/s 106% 19% -- -8% -78%
|
||||
Faster 421646/s 123% 29% 8% -- -76%
|
||||
Direct 1771243/s 836% 441% 355% 320% --
|
||||
|
||||
mutators:
|
||||
Rate Basic Average Fast Faster Direct
|
||||
Basic 173769/s -- -34% -53% -59% -90%
|
||||
Average 263046/s 51% -- -29% -38% -85%
|
||||
Fast 371158/s 114% 41% -- -13% -78%
|
||||
Faster 425821/s 145% 62% 15% -- -75%
|
||||
Direct 1699081/s 878% 546% 358% 299% --
|
||||
|
||||
Class::Accessor::Fast is faster than methods written by an average programmer
|
||||
(where "average" is based on Schwern's example code).
|
||||
|
||||
Class::Accessor is slower than average, but more flexible.
|
||||
|
||||
Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an
|
||||
array internally, not a hash. This could be a good or bad feature depending on
|
||||
your point of view.
|
||||
|
||||
Direct hash access is, of course, much faster than all of these, but it
|
||||
provides no encapsulation.
|
||||
|
||||
Of course, its not as simple as saying "Class::Accessor is slower than
|
||||
average". These are benchmarks for a simple accessor. If your accessors do
|
||||
any sort of complicated work (such as talking to a database or writing to a
|
||||
file) the time spent doing that work will quickly swamp the time spend just
|
||||
calling the accessor. In that case, Class::Accessor and the ones you write
|
||||
will be roughly the same speed.
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
Here's an example of generating an accessor for every public field of
|
||||
your class.
|
||||
|
||||
package Altoids;
|
||||
|
||||
use base qw(Class::Accessor Class::Fields);
|
||||
use fields qw(curiously strong mints);
|
||||
Altoids->mk_accessors( Altoids->show_fields('Public') );
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
return fields::new($class);
|
||||
}
|
||||
|
||||
my Altoids $tin = Altoids->new;
|
||||
|
||||
$tin->curiously('Curiouser and curiouser');
|
||||
print $tin->{curiously}; # prints 'Curiouser and curiouser'
|
||||
|
||||
|
||||
# Subclassing works, too.
|
||||
package Mint::Snuff;
|
||||
use base qw(Altoids);
|
||||
|
||||
my Mint::Snuff $pouch = Mint::Snuff->new;
|
||||
$pouch->strong('Blow your head off!');
|
||||
print $pouch->{strong}; # prints 'Blow your head off!'
|
||||
|
||||
|
||||
Here's a simple example of altering the behavior of your accessors.
|
||||
|
||||
package Foo;
|
||||
use base qw(Class::Accessor);
|
||||
Foo->mk_accessor(qw(this that up down));
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
|
||||
# Note every time someone gets some data.
|
||||
print STDERR "Getting @_\n";
|
||||
|
||||
$self->SUPER::get(@_);
|
||||
}
|
||||
|
||||
sub set {
|
||||
my ($self, $key) = splice(@_, 0, 2);
|
||||
|
||||
# Note every time someone sets some data.
|
||||
print STDERR "Setting $key to @_\n";
|
||||
|
||||
$self->SUPER::set($key, @_);
|
||||
}
|
||||
|
||||
|
||||
=head1 CAVEATS AND TRICKS
|
||||
|
||||
Class::Accessor has to do some internal wackiness to get its
|
||||
job done quickly and efficiently. Because of this, there's a few
|
||||
tricks and traps one must know about.
|
||||
|
||||
Hey, nothing's perfect.
|
||||
|
||||
=head2 Don't make a field called DESTROY
|
||||
|
||||
This is bad. Since DESTROY is a magical method it would be bad for us
|
||||
to define an accessor using that name. Class::Accessor will
|
||||
carp if you try to use it with a field named "DESTROY".
|
||||
|
||||
=head2 Overriding autogenerated accessors
|
||||
|
||||
You may want to override the autogenerated accessor with your own, yet
|
||||
have your custom accessor call the default one. For instance, maybe
|
||||
you want to have an accessor which checks its input. Normally, one
|
||||
would expect this to work:
|
||||
|
||||
package Foo;
|
||||
use base qw(Class::Accessor);
|
||||
Foo->mk_accessors(qw(email this that whatever));
|
||||
|
||||
# Only accept addresses which look valid.
|
||||
sub email {
|
||||
my($self) = shift;
|
||||
my($email) = @_;
|
||||
|
||||
if( @_ ) { # Setting
|
||||
require Email::Valid;
|
||||
unless( Email::Valid->address($email) ) {
|
||||
carp("$email doesn't look like a valid address.");
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
return $self->SUPER::email(@_);
|
||||
}
|
||||
|
||||
There's a subtle problem in the last example, and its in this line:
|
||||
|
||||
return $self->SUPER::email(@_);
|
||||
|
||||
If we look at how Foo was defined, it called mk_accessors() which
|
||||
stuck email() right into Foo's namespace. There *is* no
|
||||
SUPER::email() to delegate to! Two ways around this... first is to
|
||||
make a "pure" base class for Foo. This pure class will generate the
|
||||
accessors and provide the necessary super class for Foo to use:
|
||||
|
||||
package Pure::Organic::Foo;
|
||||
use base qw(Class::Accessor);
|
||||
Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
|
||||
|
||||
package Foo;
|
||||
use base qw(Pure::Organic::Foo);
|
||||
|
||||
And now Foo::email() can override the generated
|
||||
Pure::Organic::Foo::email() and use it as SUPER::email().
|
||||
|
||||
This is probably the most obvious solution to everyone but me.
|
||||
Instead, what first made sense to me was for mk_accessors() to define
|
||||
an alias of email(), _email_accessor(). Using this solution,
|
||||
Foo::email() would be written with:
|
||||
|
||||
return $self->_email_accessor(@_);
|
||||
|
||||
instead of the expected SUPER::email().
|
||||
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Copyright 2007 Marty Pauley <marty+perl@kasei.com>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it under
|
||||
the same terms as Perl itself. That means either (a) the GNU General Public
|
||||
License or (b) the Artistic License.
|
||||
|
||||
=head2 ORIGINAL AUTHOR
|
||||
|
||||
Michael G Schwern <schwern@pobox.com>
|
||||
|
||||
=head2 THANKS
|
||||
|
||||
Liz and RUZ for performance tweaks.
|
||||
|
||||
Tels, for his big feature request/bug report.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Class::Accessor::Fast>
|
||||
|
||||
These are some modules which do similar things in different ways
|
||||
L<Class::Struct>, L<Class::Methodmaker>, L<Class::Generate>,
|
||||
L<Class::Class>, L<Class::Contract>
|
||||
|
||||
L<Class::DBI> for an example of this module in use.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user