--- /dev/null
+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;
projects / people / pmueller / ipfire-2.x.git / blobdiff