clean_files "Class-Accessor-Grouped-* t/var";
if (-e 'MANIFEST.SKIP') {
- system('pod2text lib/Class/Accessor/Grouped.pm > README');
- realclean_files 'README';
+ system('pod2text lib/Class/Accessor/Grouped.pm > README');
+ realclean_files 'README';
}
auto_install;
# the unless defined is here so that we can override the value
# before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
$USE_XS = $ENV{CAG_USE_XS}
- unless defined $USE_XS;
+ unless defined $USE_XS;
# Yes this method is undocumented
# Yes it should be a private coderef like all the rest at the end of this file
# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
# %$*@!?&!&#*$!!!
sub _mk_group_accessors {
- my($self, $maker, $group, @fields) = @_;
- my $class = Scalar::Util::blessed $self || $self;
+ my($self, $maker, $group, @fields) = @_;
+ my $class = Scalar::Util::blessed $self || $self;
- no strict 'refs';
- no warnings 'redefine';
+ no strict 'refs';
+ no warnings 'redefine';
- # So we don't have to do lots of lookups inside the loop.
- $maker = $self->can($maker) unless ref $maker;
+ # So we don't have to do lots of lookups inside the loop.
+ $maker = $self->can($maker) unless ref $maker;
- foreach (@fields) {
- if( $_ eq 'DESTROY' ) {
- Carp::carp("Having a data accessor named DESTROY in ".
- "'$class' is unwise.");
- }
+ for (@fields) {
+ if( $_ eq 'DESTROY' ) {
+ Carp::carp("Having a data accessor named DESTROY in '$class' is unwise.");
+ }
- my ($name, $field) = (ref $_)
- ? (@$_)
- : ($_, $_)
- ;
+ my ($name, $field) = (ref $_) ? (@$_) : ($_, $_);
- my $alias = "_${name}_accessor";
+ my $alias = "_${name}_accessor";
- for my $meth ($name, $alias) {
+ for my $meth ($name, $alias) {
- # the maker may elect to not return anything, meaning it already
- # installed the coderef for us (e.g. lack of Sub::Name)
- my $cref = $self->$maker($group, $field, $meth)
- or next;
+ # the maker may elect to not return anything, meaning it already
+ # installed the coderef for us (e.g. lack of Sub::Name)
+ my $cref = $self->$maker($group, $field, $meth)
+ or next;
- my $fq_meth = "${class}::${meth}";
+ my $fq_meth = "${class}::${meth}";
- *$fq_meth = Sub::Name::subname($fq_meth, $cref);
- #unless defined &{$class."\:\:$field"}
- }
+ *$fq_meth = Sub::Name::subname($fq_meth, $cref);
+ #unless defined &{$class."\:\:$field"}
}
+ }
};
# coderef is setup at the end for clarity
=cut
sub mk_group_accessors {
- my ($self, $group, @fields) = @_;
+ my ($self, $group, @fields) = @_;
- $self->_mk_group_accessors('make_group_accessor', $group, @fields);
- return;
+ $self->_mk_group_accessors('make_group_accessor', $group, @fields);
+ return;
}
=head2 mk_group_ro_accessors
=cut
sub mk_group_ro_accessors {
- my($self, $group, @fields) = @_;
+ my($self, $group, @fields) = @_;
- $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
+ $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
}
=head2 mk_group_wo_accessors
=cut
sub mk_group_wo_accessors {
- my($self, $group, @fields) = @_;
+ my($self, $group, @fields) = @_;
- $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
+ $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
}
=head2 get_simple
=cut
sub get_simple {
- return $_[0]->{$_[1]};
+ return $_[0]->{$_[1]};
}
=head2 set_simple
=cut
sub set_simple {
- return $_[0]->{$_[1]} = $_[2];
+ return $_[0]->{$_[1]} = $_[2];
}
=cut
sub get_inherited {
- my $class;
+ my $class;
- if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
- if (Scalar::Util::reftype $_[0] eq 'HASH') {
- return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
- }
- else {
- Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
- }
+ if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
+ if (Scalar::Util::reftype $_[0] eq 'HASH') {
+ return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
}
else {
- $class = $_[0];
+ Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
}
+ }
+ else {
+ $class = $_[0];
+ }
- no strict 'refs';
- no warnings 'uninitialized';
+ no strict 'refs';
+ no warnings 'uninitialized';
- my $cag_slot = '::__cag_'. $_[1];
- return ${$class.$cag_slot} if defined(${$class.$cag_slot});
+ my $cag_slot = '::__cag_'. $_[1];
+ return ${$class.$cag_slot} if defined(${$class.$cag_slot});
- # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
- my $cur_gen = mro::get_pkg_gen ($class);
- if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
- @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
- ${$class.'::__cag_pkg_gen__'} = $cur_gen;
- }
+ # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
+ my $cur_gen = mro::get_pkg_gen ($class);
+ if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
+ @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
+ ${$class.'::__cag_pkg_gen__'} = $cur_gen;
+ }
- for (@{$class.'::__cag_supers__'}) {
- return ${$_.$cag_slot} if defined(${$_.$cag_slot});
- };
+ for (@{$class.'::__cag_supers__'}) {
+ return ${$_.$cag_slot} if defined(${$_.$cag_slot});
+ };
- return undef;
+ return undef;
}
=head2 set_inherited
=cut
sub set_inherited {
- if (defined Scalar::Util::blessed $_[0]) {
- if (Scalar::Util::reftype $_[0] eq 'HASH') {
- return $_[0]->{$_[1]} = $_[2];
- } else {
- Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
- };
+ if (defined Scalar::Util::blessed $_[0]) {
+ if (Scalar::Util::reftype $_[0] eq 'HASH') {
+ return $_[0]->{$_[1]} = $_[2];
} else {
- no strict 'refs';
-
- return ${$_[0].'::__cag_'.$_[1]} = $_[2];
+ Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
};
+ } else {
+ no strict 'refs';
+
+ return ${$_[0].'::__cag_'.$_[1]} = $_[2];
+ };
}
=head2 get_component_class
Gets the value of the specified component class.
- __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
+ __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
- $self->result_class->method();
+ $self->result_class->method();
- ## same as
- $self->get_component_class('result_class')->method();
+ ## same as
+ $self->get_component_class('result_class')->method();
=cut
sub get_component_class {
- return $_[0]->get_inherited($_[1]);
+ return $_[0]->get_inherited($_[1]);
};
=head2 set_component_class
Inherited accessor that automatically loads the specified class before setting
it. This method will die if the specified class could not be loaded.
- __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
- __PACKAGE__->result_class('MyClass');
+ __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
+ __PACKAGE__->result_class('MyClass');
- $self->result_class->method();
+ $self->result_class->method();
=cut
sub set_component_class {
- if ($_[2]) {
- local $^W = 0;
- require Class::Inspector;
- if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
- eval "require $_[2]";
+ if ($_[2]) {
+ local $^W = 0;
+ require Class::Inspector;
+ if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
+ eval "require $_[2]";
- Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
- };
+ Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
};
+ };
- return $_[0]->set_inherited($_[1], $_[2]);
+ return $_[0]->set_inherited($_[1], $_[2]);
};
=head1 INTERNAL METHODS
=cut
sub get_super_paths {
- return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
+ return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
};
=head2 make_group_accessor
# things
my $use_xs;
BEGIN {
- $Class::Accessor::Grouped::USE_XS = 0
- unless defined $Class::Accessor::Grouped::USE_XS;
- $ENV{CAG_USE_XS} = 1;
- $use_xs = $Class::Accessor::Grouped::USE_XS;
+ $Class::Accessor::Grouped::USE_XS = 0
+ unless defined $Class::Accessor::Grouped::USE_XS;
+ $ENV{CAG_USE_XS} = 1;
+ $use_xs = $Class::Accessor::Grouped::USE_XS;
};
use AccessorGroupsSubclass;
{
- my $obj = AccessorGroupsSubclass->new;
- my $class = ref $obj;
- my $name = 'multiple1';
- my $alias = "_${name}_accessor";
-
- my $warned = 0;
- local $SIG{__WARN__} = sub {
- if (shift =~ /DESTROY/i) {
- $warned++;
- };
+ my $obj = AccessorGroupsSubclass->new;
+ my $class = ref $obj;
+ my $name = 'multiple1';
+ my $alias = "_${name}_accessor";
+
+ my $warned = 0;
+ local $SIG{__WARN__} = sub {
+ if (shift =~ /DESTROY/i) {
+ $warned++;
};
+ };
- no warnings qw/once/;
- local *AccessorGroupsSubclass::DESTROY = sub {};
+ no warnings qw/once/;
+ local *AccessorGroupsSubclass::DESTROY = sub {};
- $class->mk_group_accessors('warnings', 'DESTROY');
- ok($warned);
+ $class->mk_group_accessors('warnings', 'DESTROY');
+ ok($warned);
};
my $obj = AccessorGroupsSubclass->new;
my $test_accessors = {
- singlefield => {
- is_xs => $use_xs,
- has_extra => 1,
- },
- runtime_around => {
- # even though this accessor is simple it will *not* be XSified
- # due to the runtime 'around'
- is_xs => 0,
- has_extra => 1,
- },
- multiple1 => {
- },
- multiple2 => {
- },
- lr1name => {
- custom_field => 'lr1;field',
- },
- lr2name => {
- custom_field => "lr2'field",
- },
+ singlefield => {
+ is_xs => $use_xs,
+ has_extra => 1,
+ },
+ runtime_around => {
+ # even though this accessor is simple it will *not* be XSified
+ # due to the runtime 'around'
+ is_xs => 0,
+ has_extra => 1,
+ },
+ multiple1 => {
+ },
+ multiple2 => {
+ },
+ lr1name => {
+ custom_field => 'lr1;field',
+ },
+ lr2name => {
+ custom_field => "lr2'field",
+ },
};
for my $name (sort keys %$test_accessors) {
- my $alias = "_${name}_accessor";
- my $field = $test_accessors->{$name}{custom_field} || $name;
- my $extra = $test_accessors->{$name}{has_extra};
-
- can_ok($obj, $name, $alias);
- ok(!$obj->can($field))
- if $field ne $name;
-
- for my $meth ($name, $alias) {
- my $cv = svref_2object( $obj->can($meth) );
- is($cv->GV->NAME, $meth, "$meth accessor is named");
- is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
- }
-
- is($obj->$name, undef);
- is($obj->$alias, undef);
-
- # get/set via name
- is($obj->$name('a'), 'a');
- is($obj->$name, 'a');
- is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
-
- # alias gets same as name
- is($obj->$alias, 'a');
-
- # get/set via alias
- is($obj->$alias('b'), 'b');
- is($obj->$alias, 'b');
- is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
-
- # alias gets same as name
- is($obj->$name, 'b');
-
- for my $meth ($name, $alias) {
- my $cv = svref_2object( $obj->can($meth) );
- is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
- is(
- $cv->GV->STASH->NAME,
- # XS lazyinstalls install into each caller, not into the original parent
- $test_accessors->{$name}{is_xs} ? 'AccessorGroupsSubclass' :'AccessorGroups',
- "$meth class correct after operations",
- );
- }
+ my $alias = "_${name}_accessor";
+ my $field = $test_accessors->{$name}{custom_field} || $name;
+ my $extra = $test_accessors->{$name}{has_extra};
+
+ can_ok($obj, $name, $alias);
+ ok(!$obj->can($field))
+ if $field ne $name;
+
+ for my $meth ($name, $alias) {
+ my $cv = svref_2object( $obj->can($meth) );
+ is($cv->GV->NAME, $meth, "$meth accessor is named");
+ is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
+ }
+
+ is($obj->$name, undef);
+ is($obj->$alias, undef);
+
+ # get/set via name
+ is($obj->$name('a'), 'a');
+ is($obj->$name, 'a');
+ is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
+
+ # alias gets same as name
+ is($obj->$alias, 'a');
+
+ # get/set via alias
+ is($obj->$alias('b'), 'b');
+ is($obj->$alias, 'b');
+ is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
+
+ # alias gets same as name
+ is($obj->$name, 'b');
+
+ for my $meth ($name, $alias) {
+ my $cv = svref_2object( $obj->can($meth) );
+ is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
+ is(
+ $cv->GV->STASH->NAME,
+ # XS lazyinstalls install into each caller, not into the original parent
+ $test_accessors->{$name}{is_xs} ? 'AccessorGroupsSubclass' :'AccessorGroups',
+ "$meth class correct after operations",
+ );
+ }
};
# important
# things
my $use_xs;
BEGIN {
- $Class::Accessor::Grouped::USE_XS = 0
- unless defined $Class::Accessor::Grouped::USE_XS;
- $ENV{CAG_USE_XS} = 1;
- $use_xs = $Class::Accessor::Grouped::USE_XS;
+ $Class::Accessor::Grouped::USE_XS = 0
+ unless defined $Class::Accessor::Grouped::USE_XS;
+ $ENV{CAG_USE_XS} = 1;
+ $use_xs = $Class::Accessor::Grouped::USE_XS;
};
use AccessorGroupsRO;
my $obj = AccessorGroupsRO->new;
{
- my $warned = 0;
+ my $warned = 0;
- local $SIG{__WARN__} = sub {
- if (shift =~ /DESTROY/i) {
- $warned++;
- };
+ local $SIG{__WARN__} = sub {
+ if (shift =~ /DESTROY/i) {
+ $warned++;
};
+ };
- no warnings qw/once/;
- local *AccessorGroupsRO::DESTROY = sub {};
+ no warnings qw/once/;
+ local *AccessorGroupsRO::DESTROY = sub {};
- $obj->mk_group_ro_accessors('warnings', 'DESTROY');
+ $obj->mk_group_ro_accessors('warnings', 'DESTROY');
- ok($warned);
+ ok($warned);
};
my $test_accessors = {
- singlefield => {
- is_xs => $use_xs,
- },
- multiple1 => {
- },
- multiple2 => {
- },
- lr1name => {
- custom_field => 'lr1;field',
- },
- lr2name => {
- custom_field => "lr2'field",
- },
+ singlefield => {
+ is_xs => $use_xs,
+ },
+ multiple1 => {
+ },
+ multiple2 => {
+ },
+ lr1name => {
+ custom_field => 'lr1;field',
+ },
+ lr2name => {
+ custom_field => "lr2'field",
+ },
};
for my $name (sort keys %$test_accessors) {
- my $alias = "_${name}_accessor";
- my $field = $test_accessors->{$name}{custom_field} || $name;
+ my $alias = "_${name}_accessor";
+ my $field = $test_accessors->{$name}{custom_field} || $name;
- can_ok($obj, $name, $alias);
+ can_ok($obj, $name, $alias);
- ok(!$obj->can($field))
- if $field ne $name;
+ ok(!$obj->can($field))
+ if $field ne $name;
- is($obj->$name, undef);
- is($obj->$alias, undef);
+ is($obj->$name, undef);
+ is($obj->$alias, undef);
- # get via name
- $obj->{$field} = 'a';
- is($obj->$name, 'a');
+ # get via name
+ $obj->{$field} = 'a';
+ is($obj->$name, 'a');
- # alias gets same as name
- is($obj->$alias, 'a');
+ # alias gets same as name
+ is($obj->$alias, 'a');
- my $ro_regex = $test_accessors->{$name}{is_xs}
- ? qr/Usage\:.+$name.*\(self\)/
- : qr/cannot alter the value of '\Q$field\E'/
- ;
+ my $ro_regex = $test_accessors->{$name}{is_xs}
+ ? qr/Usage\:.+$name.*\(self\)/
+ : qr/cannot alter the value of '\Q$field\E'/
+ ;
- # die on set via name/alias
- throws_ok {
- $obj->$name('b');
- } $ro_regex;
+ # die on set via name/alias
+ throws_ok {
+ $obj->$name('b');
+ } $ro_regex;
- throws_ok {
- $obj->$alias('b');
- } $ro_regex;
+ throws_ok {
+ $obj->$alias('b');
+ } $ro_regex;
- # value should be unchanged
- is($obj->$name, 'a');
- is($obj->$alias, 'a');
+ # value should be unchanged
+ is($obj->$name, 'a');
+ is($obj->$alias, 'a');
};
#important
# things
my $use_xs;
BEGIN {
- $Class::Accessor::Grouped::USE_XS = 0
- unless defined $Class::Accessor::Grouped::USE_XS;
- $ENV{CAG_USE_XS} = 1;
- $use_xs = $Class::Accessor::Grouped::USE_XS;
+ $Class::Accessor::Grouped::USE_XS = 0
+ unless defined $Class::Accessor::Grouped::USE_XS;
+ $ENV{CAG_USE_XS} = 1;
+ $use_xs = $Class::Accessor::Grouped::USE_XS;
};
use AccessorGroupsWO;
my $obj = AccessorGroupsWO->new;
{
- my $warned = 0;
+ my $warned = 0;
- local $SIG{__WARN__} = sub {
- if (shift =~ /DESTROY/i) {
- $warned++;
- };
+ local $SIG{__WARN__} = sub {
+ if (shift =~ /DESTROY/i) {
+ $warned++;
};
+ };
- no warnings qw/once/;
- local *AccessorGroupsWO::DESTROY = sub {};
+ no warnings qw/once/;
+ local *AccessorGroupsWO::DESTROY = sub {};
- $obj->mk_group_wo_accessors('warnings', 'DESTROY');
- ok($warned);
+ $obj->mk_group_wo_accessors('warnings', 'DESTROY');
+ ok($warned);
};
my $test_accessors = {
- singlefield => {
- is_xs => $use_xs,
- },
- multiple1 => {
- },
- multiple2 => {
- },
- lr1name => {
- custom_field => 'lr1;field',
- },
- lr2name => {
- custom_field => "lr2'field",
- },
+ singlefield => {
+ is_xs => $use_xs,
+ },
+ multiple1 => {
+ },
+ multiple2 => {
+ },
+ lr1name => {
+ custom_field => 'lr1;field',
+ },
+ lr2name => {
+ custom_field => "lr2'field",
+ },
};
for my $name (sort keys %$test_accessors) {
- my $alias = "_${name}_accessor";
- my $field = $test_accessors->{$name}{custom_field} || $name;
+ my $alias = "_${name}_accessor";
+ my $field = $test_accessors->{$name}{custom_field} || $name;
- can_ok($obj, $name, $alias);
+ can_ok($obj, $name, $alias);
- ok(!$obj->can($field))
- if $field ne $name;
+ ok(!$obj->can($field))
+ if $field ne $name;
- # set via name
- is($obj->$name('a'), 'a');
- is($obj->{$field}, 'a');
+ # set via name
+ is($obj->$name('a'), 'a');
+ is($obj->{$field}, 'a');
- # alias sets same as name
- is($obj->$alias('b'), 'b');
- is($obj->{$field}, 'b');
+ # alias sets same as name
+ is($obj->$alias('b'), 'b');
+ is($obj->{$field}, 'b');
- my $wo_regex = $test_accessors->{$name}{is_xs}
- ? qr/Usage\:.+$name.*\(self, newvalue\)/
- : qr/cannot access the value of '\Q$field\E'/
- ;
+ my $wo_regex = $test_accessors->{$name}{is_xs}
+ ? qr/Usage\:.+$name.*\(self, newvalue\)/
+ : qr/cannot access the value of '\Q$field\E'/
+ ;
- # die on get via name/alias
- throws_ok {
- $obj->$name;
- } $wo_regex;
+ # die on get via name/alias
+ throws_ok {
+ $obj->$name;
+ } $wo_regex;
- throws_ok {
- $obj->$alias;
- } $wo_regex;
+ throws_ok {
+ $obj->$alias;
+ } $wo_regex;
};
# important
use lib 't/lib';
BEGIN {
- require Class::Accessor::Grouped;
- my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version;
- eval {
- require Class::XSAccessor;
- Class::XSAccessor->VERSION ($xsa_ver);
- };
- plan skip_all => "Class::XSAccessor >= $xsa_ver not available"
- if $@;
+ require Class::Accessor::Grouped;
+ my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version;
+ eval {
+ require Class::XSAccessor;
+ Class::XSAccessor->VERSION ($xsa_ver);
+ };
+ plan skip_all => "Class::XSAccessor >= $xsa_ver not available"
+ if $@;
}
# rerun the regular 3 tests under XSAccessor
use lib 't/lib';
BEGIN {
- require Class::Accessor::Grouped;
- my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version;
- eval {
- require Class::XSAccessor;
- Class::XSAccessor->VERSION ($xsa_ver);
- };
- plan skip_all => "Class::XSAccessor >= $xsa_ver not available"
- if $@;
+ require Class::Accessor::Grouped;
+ my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version;
+ eval {
+ require Class::XSAccessor;
+ Class::XSAccessor->VERSION ($xsa_ver);
+ };
+ plan skip_all => "Class::XSAccessor >= $xsa_ver not available"
+ if $@;
}
use AccessorGroupsSubclass;
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More tests => 1;
+ use lib 't/lib';
+ use Test::More tests => 1;
- use_ok('Class::Accessor::Grouped');
+ use_ok('Class::Accessor::Grouped');
};
## croak on set where class can't be loaded and it's a physical class
my $dying = AccessorGroupsComp->new;
throws_ok {
- $dying->result_class('NotReallyAClass');
+ $dying->result_class('NotReallyAClass');
} qr/Could not load result_class 'NotReallyAClass'/;
is($dying->result_class, undef);
my $dying = NotHashBased->new;
throws_ok {
- $dying->killme;
+ $dying->killme;
} qr/Cannot get.*is not hash-based/;
throws_ok {
- $dying->killme('foo');
+ $dying->killme('foo');
} qr/Cannot set.*is not hash-based/;
# make sure we're get defined items, even 0, ''
}
sub new {
- return bless {}, shift;
+ return bless {}, shift;
};
foreach (qw/multiple listref/) {
- no strict 'refs';
- *{"get_$_"} = __PACKAGE__->can('get_simple');
- *{"set_$_"} = __PACKAGE__->can('set_simple');
+ no strict 'refs';
+ *{"get_$_"} = __PACKAGE__->can('get_simple');
+ *{"set_$_"} = __PACKAGE__->can('set_simple');
};
1;
__PACKAGE__->mk_group_accessors('component_class', 'result_class');
sub new {
- return bless {}, shift;
+ return bless {}, shift;
};
1;
__PACKAGE__->mk_group_ro_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
sub new {
- return bless {}, shift;
+ return bless {}, shift;
};
foreach (qw/multiple listref/) {
- no strict 'refs';
- *{"get_$_"} = __PACKAGE__->can ('get_simple');
+ no strict 'refs';
+ *{"get_$_"} = __PACKAGE__->can ('get_simple');
};
1;
__PACKAGE__->mk_group_wo_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
sub new {
- return bless {}, shift;
+ return bless {}, shift;
};
foreach (qw/multiple listref/) {
- no strict 'refs';
- *{"set_$_"} = __PACKAGE__->can('set_simple');
+ no strict 'refs';
+ *{"set_$_"} = __PACKAGE__->can('set_simple');
};
1;
__PACKAGE__->mk_group_accessors('inherited', 'basefield', 'undefined');
sub new {
- return bless {}, shift;
+ return bless {}, shift;
};
1;
use base 'Class::Accessor::Grouped';
sub new {
- return bless [], shift;
+ return bless [], shift;
};
__PACKAGE__->mk_group_accessors('inherited', 'killme');
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More;
+ use lib 't/lib';
+ use Test::More;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::CheckManifest 0.09';
- if($@) {
- plan skip_all => 'Test::CheckManifest 0.09 not installed';
- };
+ eval 'use Test::CheckManifest 0.09';
+ if($@) {
+ plan skip_all => 'Test::CheckManifest 0.09 not installed';
+ };
};
ok_manifest({
- exclude => ['/t/var', '/cover_db'],
- filter => [qr/\.(svn|git)/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/, qr/\.DS_Store/],
- bool => 'or'
+ exclude => ['/t/var', '/cover_db'],
+ filter => [qr/\.(svn|git)/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/, qr/\.DS_Store/],
+ bool => 'or'
});
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More;
+ use lib 't/lib';
+ use Test::More;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::Pod::Coverage 1.04';
- plan skip_all => 'Test::Pod::Coverage 1.04' if $@;
+ eval 'use Test::Pod::Coverage 1.04';
+ plan skip_all => 'Test::Pod::Coverage 1.04' if $@;
- eval 'use Pod::Coverage 0.14';
- plan skip_all => 'Pod::Coverage 0.14 not installed' if $@;
+ eval 'use Pod::Coverage 0.14';
+ plan skip_all => 'Pod::Coverage 0.14 not installed' if $@;
};
my $trustme = {
- trustme => [qr/^(g|s)et_component_class$/]
+ trustme => [qr/^(g|s)et_component_class$/]
};
all_pod_coverage_ok($trustme);
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More;
+ use lib 't/lib';
+ use Test::More;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::Spelling 0.11';
- plan skip_all => 'Test::Spelling 0.11 not installed' if $@;
+ eval 'use Test::Spelling 0.11';
+ plan skip_all => 'Test::Spelling 0.11 not installed' if $@;
};
set_spell_cmd('aspell list');
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More;
+ use lib 't/lib';
+ use Test::More;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::Pod 1.00';
- plan skip_all => 'Test::Pod 1.00 not installed' if $@;
+ eval 'use Test::Pod 1.00';
+ plan skip_all => 'Test::Pod 1.00 not installed' if $@;
};
all_pod_files_ok();
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More;
- use File::Find;
- use File::Basename;
+ use lib 't/lib';
+ use Test::More;
+ use File::Find;
+ use File::Basename;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::Strict';
- plan skip_all => 'Test::Strict not installed' if $@;
- plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006;
+ eval 'use Test::Strict';
+ plan skip_all => 'Test::Strict not installed' if $@;
+ plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006;
};
## I hope this can go away if Test::Strict or File::Find::Rule
## finally run under -T. Until then, I'm on my own here. ;-)
my @files;
my %trusted = (
- 'NotReallyAClass.pm' => 1
+ 'NotReallyAClass.pm' => 1
);
-find({ wanted => \&wanted,
- untaint => 1,
- untaint_pattern => qr|^([-+@\w./]+)$|,
- untaint_skip => 1,
- no_chdir => 1
+find({
+ wanted => \&wanted,
+ untaint => 1,
+ untaint_pattern => qr|^([-+@\w./]+)$|,
+ untaint_skip => 1,
+ no_chdir => 1
}, qw(lib t));
sub wanted {
- my $name = $File::Find::name;
- my $file = fileparse($name);
+ my $name = $File::Find::name;
+ my $file = fileparse($name);
- return if $name =~ /TestApp/;
+ return if $name =~ /TestApp/;
- if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) {
- push @files, $name;
- };
+ if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) {
+ push @files, $name;
+ };
};
if (scalar @files) {
- plan tests => scalar @files;
+ plan tests => scalar @files;
} else {
- plan tests => 1;
- fail 'No perl files found for Test::Strict checks!';
+ plan tests => 1;
+ fail 'No perl files found for Test::Strict checks!';
};
foreach (@files) {
- strict_ok($_);
+ strict_ok($_);
};
use warnings;
BEGIN {
- use Test::More;
+ use Test::More;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::NoTabs 0.03';
- plan skip_all => 'Test::NoTabs 0.03 not installed' if $@;
+ eval 'use Test::NoTabs 0.03';
+ plan skip_all => 'Test::NoTabs 0.03 not installed' if $@;
};
all_perl_files_ok('lib');
use warnings;
BEGIN {
- use lib 't/lib';
- use Test::More;
- use File::Find;
- use File::Basename;
+ use lib 't/lib';
+ use Test::More;
+ use File::Find;
+ use File::Basename;
- plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
+ plan skip_all => 'set TEST_AUTHOR to enable this test' unless $ENV{TEST_AUTHOR};
- eval 'use Test::Strict 0.05';
- plan skip_all => 'Test::Strict 0.05 not installed' if $@;
- plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006;
+ eval 'use Test::Strict 0.05';
+ plan skip_all => 'Test::Strict 0.05 not installed' if $@;
+ plan skip_all => 'Need untaint in newer File::Find' if $] <= 5.006;
};
## I hope this can go away if Test::Strict or File::Find::Rule
## finally run under -T. Until then, I'm on my own here. ;-)
my @files;
my %trusted = (
- 'NotReallyAClass.pm' => 1
+ 'NotReallyAClass.pm' => 1
);
-find({ wanted => \&wanted,
- untaint => 1,
- untaint_pattern => qr|^([-+@\w./]+)$|,
- untaint_skip => 1,
- no_chdir => 1
+find({
+ wanted => \&wanted,
+ untaint => 1,
+ untaint_pattern => qr|^([-+@\w./]+)$|,
+ untaint_skip => 1,
+ no_chdir => 1
}, qw(lib t));
sub wanted {
- my $name = $File::Find::name;
- my $file = fileparse($name);
+ my $name = $File::Find::name;
+ my $file = fileparse($name);
- return if $name =~ /TestApp/;
+ return if $name =~ /TestApp/;
- if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) {
- push @files, $name;
- };
+ if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) {
+ push @files, $name;
+ };
};
if (scalar @files) {
- plan tests => scalar @files;
+ plan tests => scalar @files;
} else {
- plan tests => 1;
- fail 'No perl files found for Test::Strict checks!';
+ plan tests => 1;
+ fail 'No perl files found for Test::Strict checks!';
};
foreach (@files) {
projects / p5sagit/Class-Accessor-Grouped.git / commitdiff