| Subject: | Prohibit "class accessors"? |
Currently it is possible to define some kind of "class accessors" with
accessors.pm. See the following script:
#!/usr/bin/perl
use strict;
use warnings;
{
package Foo;
use accessors qw(bla);
}
Foo->bla(2);
print Foo->bla, "\n";
# or
my $object = 'Foo'; # an accident!
print $object->bla, "\n"; # does not die!
__END__
I wonder if such a use should be forbidden. If you think it should be
forbidden, then you can apply the attached patch (which has also
additional test cases).
Regards,
Slaven
| Subject: | accessors-strict-refs.patch |
diff --git c/lib/accessors.pm w/lib/accessors.pm
index 203ee72..9b0fdf0 100644
--- c/lib/accessors.pm
+++ w/lib/accessors.pm
@@ -68,12 +68,13 @@ sub create_accessor {
$property = "-$property";
# set/get is slightly faster if we eval instead of using a closure + anon
# sub, but the difference is marginal (~5%), and this uses less memory...
- no strict 'refs';
- *{$accessor} = sub {
+ my $sub = sub {
(@_ > 1)
? ($_[0]->{$property} = $_[1], return $_[0])
: $_[0]->{$property};
};
+ no strict 'refs';
+ *{$accessor} = $sub;
}
sub isa_valid_name {
diff --git c/lib/accessors/classic.pm w/lib/accessors/classic.pm
index add9025..0c105b8 100644
--- c/lib/accessors/classic.pm
+++ w/lib/accessors/classic.pm
@@ -31,10 +31,11 @@ sub create_accessor {
my ($class, $accessor, $property) = @_;
# set/get is slightly faster if we eval instead of using a closure + anon
# sub, but the difference is marginal (~5%), and this uses less memory...
- no strict 'refs';
- *{$accessor} = sub {
+ my $sub = sub {
(@_ > 1) ? $_[0]->{$property} = $_[1] : $_[0]->{$property};
- }
+ };
+ no strict 'refs';
+ *{$accessor} = $sub;
}
1;
diff --git c/lib/accessors/ro.pm w/lib/accessors/ro.pm
index 8ca1bfb..369f86f 100755
--- c/lib/accessors/ro.pm
+++ w/lib/accessors/ro.pm
@@ -37,8 +37,9 @@ sub create_accessor {
my ($class, $accessor, $property) = @_;
# get is slightly faster if we eval instead of using a closure + anon
# sub, but the difference is marginal (~5%), and this uses less memory...
+ my $sub = sub { return $_[0]->{$property} };
no strict 'refs';
- *{$accessor} = sub { return $_[0]->{$property} };
+ *{$accessor} = $sub;
}
1;
diff --git c/t/02__chaining.t w/t/02__chaining.t
index fd10b25..f9935a4 100644
--- c/t/02__chaining.t
+++ w/t/02__chaining.t
@@ -7,7 +7,7 @@
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 13;
use Carp;
BEGIN { use_ok( "accessors::chained" ) };
@@ -22,6 +22,12 @@ is( $foo->bar( 'set' )->baz( 2 ), $foo, 'set foo->bar->baz' );
is( $foo->bar, 'set', 'get foo->bar' );
is( $foo->baz, '2', 'get foo->baz' );
+eval {
+ my $class = 'Foo';
+ $class->bar( 'set' )->baz( 2 );
+};
+isnt( $@, '', 'class accessor is an error' );
+
SKIP: {
skip '$ENV{BENCHMARK_ACCESSORS} not set', 6 unless ($ENV{BENCHMARK_ACCESSORS});
eval "use Benchmark qw( timestr countit )"; # ya never know...
diff --git c/t/03__classic.t w/t/03__classic.t
index 7396af0..93ecfa1 100644
--- c/t/03__classic.t
+++ w/t/03__classic.t
@@ -7,7 +7,7 @@
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 13;
use Carp;
BEGIN { use_ok( "accessors::classic" ) };
@@ -22,6 +22,13 @@ is( $foo->bar( 'set' ), 'set', 'set foo->bar' );
is( $foo->baz( 2 ), 2, 'set foo->baz' );
is( $foo->bar, 'set', 'get foo->bar' );
+eval {
+ my $class = 'Foo';
+ $class->bar( 'set' );
+ $class->bar;
+};
+isnt( $@, '', 'class accessor is an error' );
+
SKIP: {
skip '$ENV{BENCHMARK_ACCESSORS} not set', 6 unless ($ENV{BENCHMARK_ACCESSORS});
eval "use Benchmark qw( timestr countit )"; # ya never know...
diff --git c/t/05__default.t w/t/05__default.t
index fad10aa..75993d5 100644
--- c/t/05__default.t
+++ w/t/05__default.t
@@ -7,7 +7,7 @@
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More tests => 7;
use Carp;
BEGIN { use_ok( "accessors" ) };
@@ -21,5 +21,12 @@ ok( $foo->bar( 1 ), 'set default' );
is( $foo->bar, 1 , 'get default' );
ok( !$foo->baz, 'get default');
+eval {
+ my $class = 'Foo';
+ $class->bar( 1 );
+ $class->bar;
+};
+isnt( $@, '', 'class accessor is an error' );
+
package Foo;
use accessors qw( bar baz );
diff --git c/t/06__rw.t w/t/06__rw.t
index ea77cc0..3b37170 100644
--- c/t/06__rw.t
+++ w/t/06__rw.t
@@ -7,7 +7,7 @@
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More tests => 7;
use Carp;
BEGIN { use_ok( "accessors::rw" ) };
@@ -22,6 +22,13 @@ is( $foo->bar( 'set' ), 'set', 'set foo->bar' );
is( $foo->baz( 2 ), 2, 'set foo->baz' );
is( $foo->bar, 'set', 'get foo->bar' );
+eval {
+ my $class = 'Foo';
+ $class->bar( 1 );
+ $class->bar;
+};
+isnt( $@, '', 'class accessor is an error' );
+
# no sense benchmarking this as it inherits from accessors::classic.
package Foo;
diff --git c/t/07__ro.t w/t/07__ro.t
index dc43390..133910a 100644
--- c/t/07__ro.t
+++ w/t/07__ro.t
@@ -7,7 +7,7 @@
use strict;
use warnings;
-use Test::More tests => 13;
+use Test::More tests => 14;
use Carp;
BEGIN { use_ok( "accessors::ro" ) };
@@ -24,6 +24,12 @@ is( $foo->baz, undef, 'get foo->baz' );
$foo->{baz} = 'set';
is( $foo->baz, 'set', 'get foo->baz' );
+eval {
+ my $class = 'Foo';
+ $class->bar;
+};
+isnt( $@, '', 'class accessor is an error' );
+
SKIP: {
skip '$ENV{BENCHMARK_ACCESSORS} not set', 6 unless ($ENV{BENCHMARK_ACCESSORS});
eval "use Benchmark qw( timestr countit )"; # ya never know...