r44418 - in /branches/upstream/libclass-accessor-perl/current: Changes MANIFEST META.yml README examples/benchmark lib/Class/Accessor.pm lib/Class/Accessor/Fast.pm lib/Class/Accessor/Faster.pm t/antlers.t
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun Sep 20 17:19:23 UTC 2009
Author: jawnsy-guest
Date: Sun Sep 20 17:19:17 2009
New Revision: 44418
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=44418
Log:
[svn-upgrade] Integrating new upstream version, libclass-accessor-perl (0.34)
Added:
branches/upstream/libclass-accessor-perl/current/t/antlers.t
Modified:
branches/upstream/libclass-accessor-perl/current/Changes
branches/upstream/libclass-accessor-perl/current/MANIFEST
branches/upstream/libclass-accessor-perl/current/META.yml
branches/upstream/libclass-accessor-perl/current/README
branches/upstream/libclass-accessor-perl/current/examples/benchmark
branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor.pm
branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Fast.pm
branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Faster.pm
Modified: branches/upstream/libclass-accessor-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/Changes?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/Changes (original)
+++ branches/upstream/libclass-accessor-perl/current/Changes Sun Sep 20 17:19:17 2009
@@ -1,3 +1,6 @@
+0.34 Sat Sep 12 21:50:26 JST 2009
+ - add a Moose-like interface: I can haz "has"
+
0.33 Tue May 5 00:15:09 JST 2009
- small cleanups to fix RT#45592 and RT#43493
Modified: branches/upstream/libclass-accessor-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/MANIFEST?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/MANIFEST (original)
+++ branches/upstream/libclass-accessor-perl/current/MANIFEST Sun Sep 20 17:19:17 2009
@@ -10,6 +10,7 @@
README
t/accessors.t
t/aliases.t
+t/antlers.t
t/bestpractice.t
t/croak.t
t/getset.t
Modified: branches/upstream/libclass-accessor-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/META.yml?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/META.yml (original)
+++ branches/upstream/libclass-accessor-perl/current/META.yml Sun Sep 20 17:19:17 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Class-Accessor
-version: 0.33
+version: 0.34
abstract: ~
license: perl
author:
Modified: branches/upstream/libclass-accessor-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/README?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/README (original)
+++ branches/upstream/libclass-accessor-perl/current/README Sun Sep 20 17:19:17 2009
@@ -25,23 +25,17 @@
Done. My::Class now has simple foo(), bar() and car() accessors defined.
-BENCHMARKS
+ If you prefer a Moose-like interface you can do this instead:
- accessors:
- Rate Basic Fast Faster Direct
- Basic 367589/s -- -51% -55% -89%
- Fast 747964/s 103% -- -9% -77%
- Faster 819199/s 123% 10% -- -75%
- Direct 3245887/s 783% 334% 296% --
+ package My::Class;
+ use Class::Accessor "moose-like";
+ has foo => ( is => "rw" );
+ has bar => ( is => "rw" );
+ has car => ( is => "rw" );
- mutators:
- Rate Acc Fast Faster Direct
- Acc 265564/s -- -54% -63% -91%
- Fast 573439/s 116% -- -21% -80%
- Faster 724710/s 173% 26% -- -75%
- Direct 2860979/s 977% 399% 295% --
+ Done, again.
-AUTHORS
+AUTHOR
Copyright 2009 Marty Pauley <marty+perl at kasei.com>
@@ -49,7 +43,3 @@
under the same terms as Perl itself. That means either (a) the GNU
General Public License or (b) the Artistic License.
-ORIGINAL AUTHOR
-
- Michael G Schwern <schwern at pobox.com>
-
Modified: branches/upstream/libclass-accessor-perl/current/examples/benchmark
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/examples/benchmark?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/examples/benchmark (original)
+++ branches/upstream/libclass-accessor-perl/current/examples/benchmark Sun Sep 20 17:19:17 2009
@@ -10,50 +10,43 @@
package Bench::Direct;
use base qw(Bench::Base);
-package Bench::Class::Accessor;
-use base qw(Class::Accessor);
-__PACKAGE__->mk_accessors(qw(test));
+package Bench::Normal;
+use Class::Accessor "moose-like";
+has test => (is => "rw");
+package Bench::Fast;
+use Class::Accessor::Fast "moose-like";
+has test => (is => "rw");
-package Bench::Class::Accessor::Fast;
-use base qw(Class::Accessor::Fast);
-__PACKAGE__->mk_accessors(qw(test));
+package Bench::Faster;
+use Class::Accessor::Faster "antlers";
+has test => (is => "rw");
-package Bench::Class::Accessor::Faster;
-use base qw(Class::Accessor::Faster);
-__PACKAGE__->mk_accessors(qw(test));
+package Bench::Moose;
+use Moose;
+has test => (is => "rw");
-my %init = ( test => 23 );
-my $ca = Bench::Class::Accessor->new(\%init);
-my $fast = Bench::Class::Accessor::Fast->new(\%init);
-my $faster = Bench::Class::Accessor::Faster->new(\%init);
-my $direct = Bench::Direct->new;
-
-my $foo;
-my $control = 42;
-
+package Bench::Mouse;
+use Mouse;
+has test => (is => "rw");
package main;
+use strict;
use Benchmark 'cmpthese';
-use strict;
+
+my $tmp;
+my $direct = Bench::Direct->new({ test => 23 });
+my %accessor = ( Direct => sub { $tmp = $direct->{test}; } );
+my %mutator = ( Direct => sub { $direct->{test} = 42; } );
+for my $p (qw/Normal Fast Faster Moose Mouse/) {
+ my $o = "Bench::$p"->new({ test => 23 });
+ $accessor{$p} = sub { $tmp = $o->test; };
+ $mutator{$p} = sub { $o->test(42); };
+}
print "accessors:\n";
-cmpthese( -1,
- {
- 'Basic' => sub { $foo = $ca->test; },
- 'Fast' => sub { $foo = $fast->test; },
- 'Faster' => sub { $foo = $faster->test; },
- 'Direct' => sub { $foo = $direct->{test}; }
- }
- );
+cmpthese( -10, \%accessor );
+print "\n";
+print "mutators:\n";
+cmpthese( -10, \%mutator );
-print "mutators:\n";
-cmpthese( -1,
- {
- 'Acc' => sub { $ca->test(42); },
- 'Fast' => sub { $fast->test(42); },
- 'Faster' => sub { $faster->test(42); },
- 'Direct' => sub { $direct->{test} = 42; }
- }
- );
-
Modified: branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor.pm?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor.pm (original)
+++ branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor.pm Sun Sep 20 17:19:17 2009
@@ -1,127 +1,7 @@
package Class::Accessor;
require 5.00502;
use strict;
-$Class::Accessor::VERSION = '0.33';
-
-=head1 NAME
-
- Class::Accessor - Automated accessor generation
-
-=head1 SYNOPSIS
-
- package Foo;
- use base qw(Class::Accessor);
- Foo->follow_best_practice;
- Foo->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 it's 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 Foo;
- use base qw(Class::Accessor);
- Foo->mk_accessors( qw(far bar car) );
-
-Done. Foo now has simple far(), bar() and car() accessors
-defined.
-
-Alternatively, if you want to follow Damian's I<best practice> guidelines
-you can use:
-
- package Foo;
- use base qw(Class::Accessor);
- Foo->follow_best_practice;
- Foo->mk_accessors( qw(far bar car) );
-
-B<Note:> you must call C<follow_best_practice> before calling C<mk_accessors>.
-
-=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 = Foo->new;
- my $obj = $other_obj->new;
-
- my $obj = Foo->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 = Foo->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
+$Class::Accessor::VERSION = '0.34';
sub new {
my($proto, $fields) = @_;
@@ -133,23 +13,6 @@
bless {%$fields}, $class;
}
-=head2 mk_accessors
-
- __PACKAGE__->mk_accessors(@fields);
-
-This creates accessor/mutator methods for each named field given in
- at 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().
- __PACKAGE__->mk_accessors(qw(foo bar));
-
-See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
-for details.
-
-=cut
-
sub mk_accessors {
my($self, @fields) = @_;
@@ -162,6 +25,28 @@
{
no strict 'refs';
+
+ sub import {
+ my ($class, @what) = @_;
+ my $caller = caller;
+ for (@what) {
+ if (/^(?:antlers|moose-?like)$/i) {
+ *{"${caller}::has"} = sub {
+ my ($f, %args) = @_;
+ $caller->_mk_accessors(($args{is}||"rw"), $f);
+ };
+ *{"${caller}::extends"} = sub {
+ @{"${caller}::ISA"} = @_;
+ unless (grep $_->can("_mk_accessors"), @_) {
+ push @{"${caller}::ISA"}, $class;
+ }
+ };
+ # we'll use their @ISA as a default, in case it happens to be
+ # set already
+ &{"${caller}::extends"}(@{"${caller}::ISA"});
+ }
+ }
+ }
sub follow_best_practice {
my($self) = @_;
@@ -223,7 +108,291 @@
}
-
+sub mk_ro_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('ro', @fields);
+}
+
+sub mk_wo_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('wo', @fields);
+}
+
+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;
+}
+
+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");
+ }
+}
+
+sub get {
+ my $self = shift;
+
+ if(@_ == 1) {
+ return $self->{$_[0]};
+ }
+ elsif( @_ > 1 ) {
+ return @{$self}{@_};
+ }
+ else {
+ $self->_croak("Wrong number of arguments received");
+ }
+}
+
+sub make_accessor {
+ my ($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+
+ if(@_) {
+ return $self->set($field, @_);
+ } else {
+ return $self->get($field);
+ }
+ };
+}
+
+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);
+ }
+ };
+}
+
+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, @_);
+ }
+ };
+}
+
+
+use Carp ();
+
+sub _carp {
+ my ($self, $msg) = @_;
+ Carp::carp($msg || $self);
+ return;
+}
+
+sub _croak {
+ my ($self, $msg) = @_;
+ Carp::croak($msg || $self);
+ return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ Class::Accessor - Automated accessor generation
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->follow_best_practice;
+ Foo->mk_accessors(qw(name role salary));
+
+ # or if you prefer a Moose-like interface...
+
+ package Foo;
+ use Class::Accessor "antlers";
+ has name => ( is => "rw", isa => "Str" );
+ has role => ( is => "rw", isa => "Str" );
+ has salary => ( is => "rw", isa => "Num" );
+
+ # 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 it's 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 Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors( qw(far bar car) );
+
+Done. Foo now has simple far(), bar() and car() accessors
+defined.
+
+Alternatively, if you want to follow Damian's I<best practice> guidelines
+you can use:
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->follow_best_practice;
+ Foo->mk_accessors( qw(far bar car) );
+
+B<Note:> you must call C<follow_best_practice> before calling C<mk_accessors>.
+
+=head2 Moose-like
+
+By popular demand we now have a simple Moose-like interface. You can now do:
+
+ package Foo;
+ use Class::Accessor "antlers";
+ has far => ( is => "rw" );
+ has bar => ( is => "rw" );
+ has car => ( is => "rw" );
+
+Currently only the C<is> attribute is supported.
+
+=head1 CONSTRUCTOR
+
+Class::Accessor provides a basic constructor, C<new>. It generates a
+hash-based object and can be called as either a class method or an
+object method.
+
+=head2 new
+
+ my $obj = Foo->new;
+ my $obj = $other_obj->new;
+
+ my $obj = Foo->new(\%fields);
+ my $obj = $other_obj->new(\%fields);
+
+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 = Foo->new({ foo => 42 });
+ print $obj->foo; # 42
+
+however %fields can contain anything, new() will shove them all into
+your object.
+
+=head1 MAKING ACCESSORS
+
+=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
+
+B<before> you call any of the accessor-making methods.
+
+=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.)
+
+=head2 mk_accessors
+
+ __PACKAGE__->mk_accessors(@fields);
+
+This creates accessor/mutator methods for each named field given in
+ at 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().
+ __PACKAGE__->mk_accessors(qw(foo bar));
+
+See L<CAVEATS AND TRICKS/"Overriding autogenerated accessors">
+for details.
=head2 mk_ro_accessors
@@ -243,14 +412,6 @@
$foo->foo(42); # BOOM! Naughty you.
-=cut
-
-sub mk_ro_accessors {
- my($self, @fields) = @_;
-
- $self->_mk_accessors('ro', @fields);
-}
-
=head2 mk_wo_accessors
__PACKAGE__->mk_wo_accessors(@write_only_fields);
@@ -271,13 +432,34 @@
$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 Moose!
+
+If you prefer a Moose-like interface to create accessors, you can use C<has> by
+importing this module like this:
+
+ use Class::Accessor "antlers";
+
+or
+
+ use Class::Accessor "moose-like";
+
+Then you can declare accessors like this:
+
+ has alpha => ( is => "rw", isa => "Str" );
+ has beta => ( is => "ro", isa => "Str" );
+ has gamma => ( is => "wo", isa => "Str" );
+
+Currently only the C<is> attribute is supported. And our C<is> also supports
+the "wo" value to make a write-only accessor.
+
+If you are using the Moose-like interface then you should use the C<extends>
+rather than tweaking your C<@ISA> directly. Basically, replace
+
+ @ISA = qw/Foo Bar/;
+
+with
+
+ extends(qw/Foo Bar/);
=head1 DETAILS
@@ -300,44 +482,6 @@
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
-
-B<before> you call mk_accessors.
-
-=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
@@ -355,22 +499,6 @@
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);
@@ -380,22 +508,6 @@
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 = __PACKAGE__->make_accessor($field);
@@ -406,24 +518,6 @@
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 = __PACKAGE__->make_ro_accessor($field);
@@ -433,24 +527,6 @@
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 = __PACKAGE__->make_wo_accessor($field);
@@ -459,46 +535,12 @@
(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
@@ -670,7 +712,7 @@
=head1 AUTHORS
-Copyright 2007 Marty Pauley <marty+perl at kasei.com>
+Copyright 2009 Marty Pauley <marty+perl at 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
@@ -686,17 +728,17 @@
Tels, for his big feature request/bug report.
+Various presenters at YAPC::Asia 2009 for criticising the non-Moose interface.
=head1 SEE ALSO
-L<Class::Accessor::Fast>
+See L<Class::Accessor::Fast> and L<Class::Accessor::Faster> if speed is more
+important than flexibility.
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.
+L<Class::Class>, L<Class::Contract>, L<Moose>, L<Mouse>
+
+See L<Class::DBI> for an example of this module in use.
=cut
-
-1;
Modified: branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Fast.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Fast.pm?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Fast.pm (original)
+++ branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Fast.pm Sun Sep 20 17:19:17 2009
@@ -1,43 +1,14 @@
package Class::Accessor::Fast;
use base 'Class::Accessor';
use strict;
-$Class::Accessor::Fast::VERSION = '0.33';
-
-=head1 NAME
-
-Class::Accessor::Fast - Faster, but less expandable, accessors
-
-=head1 SYNOPSIS
-
- package Foo;
- use base qw(Class::Accessor::Fast);
-
- # The rest is the same as Class::Accessor but without set() and get().
-
-=head1 DESCRIPTION
-
-This is a faster but less expandable version of Class::Accessor.
-Class::Accessor's generated accessors require two method calls to accompish
-their task (one for the accessor, another for get() or set()).
-Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
-resulting in a somewhat faster accessor.
-
-The downside is that you can't easily alter the behavior of your
-accessors, nor can your subclasses. Of course, should you need this
-later, you can always swap out Class::Accessor::Fast for
-Class::Accessor.
-
-Read the documentation for Class::Accessor for more info.
-
-=cut
+$Class::Accessor::Fast::VERSION = '0.34';
sub make_accessor {
my($class, $field) = @_;
return sub {
- return $_[0]->{$field} if @_ == 1;
- return $_[0]->{$field} = $_[1] if @_ == 2;
- return (shift)->{$field} = \@_;
+ return $_[0]->{$field} if scalar(@_) == 1;
+ return $_[0]->{$field} = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]];
};
}
@@ -69,6 +40,36 @@
}
+1;
+
+__END__
+
+=head1 NAME
+
+Class::Accessor::Fast - Faster, but less expandable, accessors
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor::Fast);
+
+ # The rest is the same as Class::Accessor but without set() and get().
+
+=head1 DESCRIPTION
+
+This is a faster but less expandable version of Class::Accessor.
+Class::Accessor's generated accessors require two method calls to accompish
+their task (one for the accessor, another for get() or set()).
+Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
+resulting in a somewhat faster accessor.
+
+The downside is that you can't easily alter the behavior of your
+accessors, nor can your subclasses. Of course, should you need this
+later, you can always swap out Class::Accessor::Fast for
+Class::Accessor.
+
+Read the documentation for Class::Accessor for more info.
+
=head1 EFFICIENCY
L<Class::Accessor/EFFICIENCY> for an efficiency comparison.
@@ -90,5 +91,3 @@
L<Class::Accessor>
=cut
-
-1;
Modified: branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Faster.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Faster.pm?rev=44418&op=diff
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Faster.pm (original)
+++ branches/upstream/libclass-accessor-perl/current/lib/Class/Accessor/Faster.pm Sun Sep 20 17:19:17 2009
@@ -1,32 +1,7 @@
package Class::Accessor::Faster;
use base 'Class::Accessor';
use strict;
-$Class::Accessor::Faster::VERSION = '0.33';
-
-=head1 NAME
-
-Class::Accessor::Faster - Even faster, but less expandable, accessors
-
-=head1 SYNOPSIS
-
- package Foo;
- use base qw(Class::Accessor::Faster);
-
-=head1 DESCRIPTION
-
-This is a faster but less expandable version of Class::Accessor::Fast.
-
-Class::Accessor's generated accessors require two method calls to accompish
-their task (one for the accessor, another for get() or set()).
-
-Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
-resulting in a somewhat faster accessor.
-
-Class::Accessor::Faster uses an array reference underneath to be faster.
-
-Read the documentation for Class::Accessor for more info.
-
-=cut
+$Class::Accessor::Faster::VERSION = '0.34';
my %slot;
sub _slot {
@@ -55,12 +30,10 @@
my($class, $field) = @_;
my $n = $class->_slot($field);
return sub {
- return $_[0]->[$n] if @_ == 1;
- return $_[0]->[$n] = $_[1] if @_ == 2;
- return (shift)->[$n] = \@_;
+ return $_[0]->[$n] if scalar(@_) == 1;
+ return $_[0]->[$n] = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]];
};
}
-
sub make_ro_accessor {
my($class, $field) = @_;
@@ -71,7 +44,6 @@
$_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
};
}
-
sub make_wo_accessor {
my($class, $field) = @_;
@@ -87,6 +59,32 @@
};
}
+1;
+
+__END__
+
+=head1 NAME
+
+Class::Accessor::Faster - Even faster, but less expandable, accessors
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor::Faster);
+
+=head1 DESCRIPTION
+
+This is a faster but less expandable version of Class::Accessor::Fast.
+
+Class::Accessor's generated accessors require two method calls to accompish
+their task (one for the accessor, another for get() or set()).
+
+Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
+resulting in a somewhat faster accessor.
+
+Class::Accessor::Faster uses an array reference underneath to be faster.
+
+Read the documentation for Class::Accessor for more info.
=head1 AUTHORS
@@ -101,5 +99,3 @@
L<Class::Accessor>
=cut
-
-1;
Added: branches/upstream/libclass-accessor-perl/current/t/antlers.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libclass-accessor-perl/current/t/antlers.t?rev=44418&op=file
==============================================================================
--- branches/upstream/libclass-accessor-perl/current/t/antlers.t (added)
+++ branches/upstream/libclass-accessor-perl/current/t/antlers.t Sun Sep 20 17:19:17 2009
@@ -1,0 +1,56 @@
+#!perl
+use strict;
+use Test::More tests => 14;
+
+package No::Silly::Hands;
+use Class::Accessor;
+::ok !defined &has, "I can haz has?";
+
+package Silly::Hands;
+use Class::Accessor "antlers";
+::ok defined &has, "I iz in ur module";
+
+has "foo";
+has rwrw => ( is => "rw", isa => "Int" );
+has roro => ( is => "ro", isa => "Str" );
+has wowo => ( is => "wo", isa => "Str" );
+
+package main;
+for my $f (qw/foo roro wowo rwrw/) {
+ ok +Silly::Hands->can($f), "'$f' method exists";
+}
+
+my $test = Silly::Hands->new({
+ foo => "bar",
+ roro => "boat",
+ rwrw => "huh",
+ wowo => "whoa",
+});
+
+is($test->foo, "bar", "initial foo");
+$test->foo("stuff");
+is($test->foo, "stuff", "new foo");
+is($test->{foo}, "stuff", "new foo in hash");
+
+is($test->roro, 'boat', 'ro accessor');
+eval { $test->roro('stuff'); };
+like(scalar $@,
+ qr/cannot alter the value of 'roro' on objects of class 'Silly::Hands'/,
+ 'ro accessor write protection');
+
+$test->wowo(1001001);
+is( $test->{wowo}, 1001001, 'wo accessor');
+eval { () = $test->wowo; };
+like(scalar $@,
+ qr/cannot access the value of 'wowo' on objects of class 'Silly::Hands'/,
+ 'wo accessor read protection' );
+
+package Silly::Hands;
+{
+ my $eeek;
+ local $SIG{__WARN__} = sub { $eeek = shift };
+ has DESTROY => (is => "rw");
+ ::like($eeek,
+ qr/a data accessor named DESTROY/i,
+ 'mk DESTROY accessor warning');
+};
More information about the Pkg-perl-cvs-commits
mailing list