Class-Accessor-Grouped-0.10012/0000755000175000017500000000000012414333163015355 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/t/0000755000175000017500000000000012414333163015620 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/t/pod_coverage.t0000644000175000017500000000067412044165115020450 0ustar rabbitrabbituse strict; use warnings; BEGIN { use lib 't/lib'; use Test::More; 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 Pod::Coverage 0.14'; plan skip_all => 'Pod::Coverage 0.14 not installed' if $@; }; my $trustme = { trustme => [qr/^(g|s)et_component_class$/] }; all_pod_coverage_ok($trustme); Class-Accessor-Grouped-0.10012/t/lib/0000755000175000017500000000000012414333163016366 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/t/lib/AccessorGroupsRO.pm0000644000175000017500000000110412047714752022134 0ustar rabbitrabbitpackage AccessorGroupsRO; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_ro_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_ro_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_ro_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); __PACKAGE__->mk_group_ro_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]); sub new { return bless {}, shift; }; foreach (qw/multiple listref/) { no strict 'refs'; *{"get_$_"} = __PACKAGE__->can ('get_simple'); }; 1; Class-Accessor-Grouped-0.10012/t/lib/AccessorGroups.pm0000644000175000017500000000204012124441262021660 0ustar rabbitrabbitpackage AccessorGroups; use strict; use warnings; use base 'AccessorGroupsParent'; __PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', reverse map { chr($_) } (0..255) ) ]); sub get_simple { my $v = shift->SUPER::get_simple (@_); $v =~ s/ Extra tackled on$// if $v; $v; } sub set_simple { my ($self, $f, $v) = @_; $v .= ' Extra tackled on' if $f eq 'singlefield'; $self->SUPER::set_simple ($f, $v); $_[2]; } # a runtime Class::Method::Modifiers style around # the eval/our combo is so that we do not need to rely on Sub::Name being available my $orig_ra_cref = __PACKAGE__->can('runtime_around'); our $around_cref = sub { my $self = shift; if (@_) { my $val = shift; $self->$orig_ra_cref($val . ' Extra tackled on'); $val; } else { my $val = $self->$orig_ra_cref; $val =~ s/ Extra tackled on$// if defined $val; $val; } }; { no warnings qw/redefine/; eval <<'EOE'; sub runtime_around { goto $around_cref }; sub _runtime_around_accessor { goto $around_cref }; EOE } 1; Class-Accessor-Grouped-0.10012/t/lib/SuperInheritedGroups.pm0000644000175000017500000000013411664037521023061 0ustar rabbitrabbitpackage SuperInheritedGroups; use strict; use warnings; use base 'BaseInheritedGroups'; 1; Class-Accessor-Grouped-0.10012/t/lib/NotHashBased.pm0000644000175000017500000000027212044165115021227 0ustar rabbitrabbitpackage NotHashBased; use strict; use warnings; use base 'Class::Accessor::Grouped'; sub new { return bless [], shift; }; __PACKAGE__->mk_group_accessors('inherited', 'killme'); 1; Class-Accessor-Grouped-0.10012/t/lib/AccessorGroupsComp.pm0000644000175000017500000000031412044165115022502 0ustar rabbitrabbitpackage AccessorGroupsComp; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('component_class', 'result_class'); sub new { return bless {}, shift; }; 1; Class-Accessor-Grouped-0.10012/t/lib/ExtraInheritedGroups.pm0000644000175000017500000000033311664037521023047 0ustar rabbitrabbitpackage ExtraInheritedGroups; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('inherited', 'basefield'); __PACKAGE__->set_inherited (basefield => 'your extra base!'); 1; Class-Accessor-Grouped-0.10012/t/lib/AccessorGroupsSubclass.pm0000644000175000017500000000013112121364073023360 0ustar rabbitrabbitpackage AccessorGroupsSubclass; use strict; use warnings; use base 'AccessorGroups'; 1; Class-Accessor-Grouped-0.10012/t/lib/NotReallyAClass.pm0000644000175000017500000000000011664037521021717 0ustar rabbitrabbitClass-Accessor-Grouped-0.10012/t/lib/AccessorGroupsParent.pm0000644000175000017500000000200112124441262023027 0ustar rabbitrabbitBEGIN { package AccessorGroups::BeenThereDoneThat; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); my $dummy = bless {}; # tickle stuff at BEGIN time $dummy->singlefield('foo'); } package AccessorGroupsParent; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); __PACKAGE__->mk_group_accessors('simple', 'runtime_around'); __PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]); sub new { return bless {}, shift; }; foreach (qw/multiple listref/) { no strict 'refs'; *{"get_$_"} = __PACKAGE__->can('get_simple'); *{"set_$_"} = __PACKAGE__->can('set_simple'); }; 1; Class-Accessor-Grouped-0.10012/t/lib/BaseInheritedGroups.pm0000644000175000017500000000032112044165115022625 0ustar rabbitrabbitpackage BaseInheritedGroups; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_accessors('inherited', 'basefield', 'undefined'); sub new { return bless {}, shift; }; 1; Class-Accessor-Grouped-0.10012/t/lib/AccessorGroupsWO.pm0000644000175000017500000000110312047714752022140 0ustar rabbitrabbitpackage AccessorGroupsWO; use strict; use warnings; use base 'Class::Accessor::Grouped'; __PACKAGE__->mk_group_wo_accessors('simple', 'singlefield'); __PACKAGE__->mk_group_wo_accessors('multiple', qw/multiple1 multiple2/); __PACKAGE__->mk_group_wo_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]); __PACKAGE__->mk_group_wo_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]); sub new { return bless {}, shift; }; foreach (qw/multiple listref/) { no strict 'refs'; *{"set_$_"} = __PACKAGE__->can('set_simple'); }; 1; Class-Accessor-Grouped-0.10012/t/basic.t0000644000175000017500000000072212044177546017101 0ustar rabbitrabbituse strict; use warnings; use Test::More; use B qw/svref_2object/; use_ok('Class::Accessor::Grouped'); # ensure core accessor types are properly named # for (qw/simple inherited component_class/) { for my $meth ("get_$_", "set_$_") { my $cv = svref_2object( Class::Accessor::Grouped->can($meth) ); is($cv->GV->NAME, $meth, "$meth accessor is named"); is($cv->GV->STASH->NAME, 'Class::Accessor::Grouped', "$meth class correct"); } } done_testing; Class-Accessor-Grouped-0.10012/t/style_no_tabs.t0000644000175000017500000000040412044165115020647 0ustar rabbitrabbituse strict; use warnings; BEGIN { use Test::More; 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 $@; }; all_perl_files_ok('lib'); Class-Accessor-Grouped-0.10012/t/accessors_pp.t0000644000175000017500000000414112412046614020471 0ustar rabbitrabbitmy $has_threads; BEGIN { eval ' use 5.008001; use threads; use threads::shared; $has_threads = 1; ' } use strict; use warnings; no warnings 'once'; use FindBin qw($Bin); use File::Spec::Functions; use File::Spec::Unix (); # need this for %INC munging use Test::More; use lib 't/lib'; BEGIN { local $ENV{DEVEL_HIDE_VERBOSE} = 0; eval { require Devel::Hide }; if ($@) { eval { require Sub::Name }; plan skip_all => "Devel::Hide required for this test in presence of Sub::Name" if ! $@; } else { Devel::Hide->import('Sub/Name.pm'); } require Class::Accessor::Grouped; } # rerun the regular 3 tests under the assumption of no Sub::Name our $SUBTESTING = 1; for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) { my $pass = 1; share($pass) if $has_threads; my $todo = sub { note "\nTesting $tname without Sub::Name (pass @{[ $pass ++ ]})\n\n"; my ($tfn) = catfile($Bin, $tname) =~ /(.+)/; for ( qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsParent.pm AccessorGroupsWO.pm|, File::Spec::Unix->catfile ($tfn), ) { delete $INC{$_}; no strict 'refs'; if (my ($mod) = $_ =~ /(.+)\.pm$/ ) { %{"${mod}::"} = (); } } local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i }; do($tfn); 666; }; if ($has_threads) { for (1,2) { is ( threads->create(sub { # nested threading of this sort badly blows up on 5.10.0 (fixed with 5.10.1) unless ($] > 5.009 and $] < 5.010001) { is ( threads->create(sub { $todo->(); })->join, 666, 'Innner thread joined ok', ); is ($todo->(), 666, "Intermediate result ok"); } return 777; })->join, 777, 'Outer thread joined ok', ); is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } else { is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } done_testing; Class-Accessor-Grouped-0.10012/t/accessors.t0000644000175000017500000001016112160346514017773 0ustar rabbitrabbituse Test::More; use strict; use warnings; no warnings 'once'; use lib 't/lib'; use B qw/svref_2object/; # we test the pure-perl versions only, but allow overrides # from the accessor_xs test-umbrella # Also make sure a rogue envvar will not interfere with # 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; }; require AccessorGroupsSubclass; my $test_accessors = { singlefield => { is_simple => 1, has_extra => 1, }, runtime_around => { # even though this accessor is declared as simple it will *not* be # reinstalled due to the runtime 'around' forced_class => 'AccessorGroups', is_simple => 1, has_extra => 1, }, multiple1 => { }, multiple2 => { }, lr1name => { custom_field => 'lr1;field', }, lr2name => { custom_field => "lr2'field", }, fieldname_torture => { is_simple => 1, custom_field => join ('', map { chr($_) } (0..255) ), }, }; for my $class (qw( AccessorGroupsSubclass AccessorGroups AccessorGroupsParent )) { my $obj = $class->new; 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}; my $origin_class = 'AccessorGroupsParent'; if ( $class eq 'AccessorGroupsParent' ) { next if $name eq 'runtime_around'; # implemented in the AG subclass $extra = 0; } elsif ($name eq 'fieldname_torture') { $field = reverse $field; $origin_class = 'AccessorGroups'; } can_ok($obj, $name, $alias); ok(!$obj->can($field), "field for $name is not a method on $class") if $field ne $name; my $init_shims; # initial method name for my $meth ($name, $alias) { my $cv = svref_2object( $init_shims->{$meth} = $obj->can($meth) ); is($cv->GV->NAME, $meth, "initial ${class}::$meth accessor is named"); is( $cv->GV->STASH->NAME, $test_accessors->{$name}{forced_class} || $origin_class, "initial ${class}::$meth origin class correct", ); } is($obj->$name, undef, "${class}::$name begins undef"); is($obj->$alias, undef, "${class}::$alias begins undef"); # get/set via name is($obj->$name('a'), 'a', "${class}::$name setter RV correct"); is($obj->$name, 'a', "${class}::$name getter correct"); is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a', "${class}::$name corresponding field correct"); # alias gets same as name is($obj->$alias, 'a', "${class}::$alias getter correct after ${class}::$name setter"); # get/set via alias is($obj->$alias('b'), 'b', "${class}::$alias setter RV correct"); is($obj->$alias, 'b', "${class}::$alias getter correct"); is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b', "${class}::$alias corresponding field still correct"); # alias gets same as name is($obj->$name, 'b', "${class}::$name getter correct after ${class}::$alias setter"); for my $meth ($name, $alias) { my $resolved = $obj->can($meth); my $cv = svref_2object($resolved); is($cv->GV->NAME, $meth, "$meth accessor is named after operations"); is( $cv->GV->STASH->NAME, # XS deferred subs install into each caller, not into the original parent $test_accessors->{$name}{forced_class} || ( ($use_xs and $test_accessors->{$name}{is_simple}) ? (ref $obj) : $origin_class ), "${class}::$meth origin class correct after operations", ); # just simple for now if ($use_xs and $test_accessors->{$name}{is_simple} and ! $test_accessors->{$name}{forced_class}) { ok ($resolved != $init_shims->{$meth}, "$meth was replaced with a resolved version"); if ($class eq 'AccessorGroupsParent') { ok ($cv->XSUB, "${class}::$meth is an XSUB"); } else { ok (!$cv->XSUB, "${class}::$meth is *not* an XSUB (due to get_simple overrides)"); } } } } } done_testing unless $::SUBTESTING; Class-Accessor-Grouped-0.10012/t/pod_syntax.t0000644000175000017500000000041312044165115020172 0ustar rabbitrabbituse strict; use warnings; BEGIN { use lib 't/lib'; use Test::More; 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 $@; }; all_pod_files_ok(); Class-Accessor-Grouped-0.10012/t/strict.t0000644000175000017500000000204212044165115017312 0ustar rabbitrabbituse strict; use warnings; BEGIN { 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}; 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 ); 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); return if $name =~ /TestApp/; if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) { push @files, $name; }; }; if (scalar @files) { plan tests => scalar @files; } else { plan tests => 1; fail 'No perl files found for Test::Strict checks!'; }; foreach (@files) { strict_ok($_); }; Class-Accessor-Grouped-0.10012/t/clean_namespace.t0000644000175000017500000000207612131160353021103 0ustar rabbitrabbituse Test::More; use strict; use warnings; BEGIN { plan skip_all => "Package::Stash required for this test" unless eval { require Package::Stash }; require MRO::Compat if $] < 5.009_005; } { package AccessorGroups::Clean; use strict; use warnings; use base 'Class::Accessor::Grouped'; my $obj = bless {}; for (qw/simple inherited component_class/) { __PACKAGE__->mk_group_accessors($_ => "${_}_a"); $obj->${\ "${_}_a"} ('blah'); } } is_deeply [ sort keys %{ { map { %{Package::Stash->new($_)->get_all_symbols('CODE')} } (reverse @{mro::get_linear_isa('AccessorGroups::Clean')}) } } ], [ sort +( (map { ( "$_", "_${_}_accessor" ) } qw/simple_a inherited_a component_class_a/ ), (map { ( "get_$_", "set_$_" ) } qw/simple inherited component_class/ ), qw/ _mk_group_accessors get_super_paths make_group_accessor make_group_ro_accessor make_group_wo_accessor mk_group_accessors mk_group_ro_accessors mk_group_wo_accessors CLONE /, )], 'Expected list of methods in a freshly inheriting class'; done_testing; Class-Accessor-Grouped-0.10012/t/pod_spelling.t0000644000175000017500000000110012051235562020455 0ustar rabbitrabbituse strict; use warnings; BEGIN { use lib 't/lib'; use Test::More; 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 $@; }; set_spell_cmd('aspell list'); add_stopwords(); all_pod_files_spelling_ok(); __DATA__ Bowden Raygun Roditi isa mst behaviour further overridable Laco Pauley claco stylings fieldspec listref getters ribasushi Rabbitson groditi Caelum Kitover CAF Sep XSA OTRW runtime Axel fREW frew getter subclasses BenchmarkingClass-Accessor-Grouped-0.10012/t/accessors_ro.t0000644000175000017500000000412712411242035020470 0ustar rabbitrabbituse Test::More; use Test::Exception; use strict; use warnings; no warnings 'once'; use lib 't/lib'; # we test the pure-perl versions only, but allow overrides # from the accessor_xs test-umbrella # Also make sure a rogue envvar will not interfere with # 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; }; use AccessorGroupsRO; my $obj = AccessorGroupsRO->new; { my $warned = 0; local $SIG{__WARN__} = sub { if (shift =~ /DESTROY/i) { $warned++; }; }; no warnings qw/once/; local *AccessorGroupsRO::DESTROY = sub {}; $obj->mk_group_ro_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", }, fieldname_torture => { custom_field => join ('', map { chr($_) } (0..255) ), is_xs => $use_xs, }, }; for my $name (sort keys %$test_accessors) { my $alias = "_${name}_accessor"; my $field = $test_accessors->{$name}{custom_field} || $name; can_ok($obj, $name, $alias); ok(!$obj->can($field)) if $field ne $name; is($obj->$name, undef); is($obj->$alias, undef); # get via name $obj->{$field} = 'a'; is($obj->$name, 'a'); # alias gets same as name is($obj->$alias, 'a'); my $ro_regex = $test_accessors->{$name}{is_xs} ? qr/Usage\:.+$name.*\(self\)/ : qr/$name(:?_accessor)?\Q' cannot alter its value (read-only attribute of class AccessorGroupsRO)/ ; SKIP: { skip "Class::XSAccessor emits broken error messages on 5.10 and earlier", 1 if ( $test_accessors->{$name}{is_xs} and $] < '5.011' ); # die on set via name/alias throws_ok { $obj->$name('b'); } $ro_regex; throws_ok { $obj->$alias('b'); } $ro_regex; } # value should be unchanged is($obj->$name, 'a'); is($obj->$alias, 'a'); }; done_testing unless $::SUBTESTING; Class-Accessor-Grouped-0.10012/t/accessors_xs_cachedwarn.t0000644000175000017500000000316312411507212022661 0ustar rabbitrabbitmy $has_threads; BEGIN { eval ' use 5.008005; # older perls get confused by $SIG fiddling under CXSA use threads; use threads::shared; $has_threads = 1; ' } use strict; use warnings; use Test::More; use lib 't/lib'; BEGIN { plan skip_all => "Sub::Name not available" unless eval { require Sub::Name }; 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; my @w; share(@w) if $has_threads; { my $obj = AccessorGroupsSubclass->new; my $deferred_stub = AccessorGroupsSubclass->can('singlefield'); my $obj2 = AccessorGroups->new; my $todo = sub { local $SIG{__WARN__} = sub { push @w, @_ }; is ($obj->$deferred_stub(1), 1, 'Set'); is ($obj->$deferred_stub, 1, 'Get'); is ($obj->$deferred_stub(2), 2, 'ReSet'); is ($obj->$deferred_stub, 2, 'ReGet'); is ($obj->singlefield, 2, 'Normal get'); is ($obj2->singlefield, undef, 'Normal get on unrelated object'); 42; }; is ( ($has_threads ? threads->create( $todo )->join : $todo->()), 42, "Correct result after do-er", ) } is (@w, 3, '3 warnings total'); is ( scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroupsParent::singlefield invoked more than once/ } @w), 3, '3 warnings produced as expected on cached invocation during testing', ) or do { require Data::Dumper; diag "\n \$0 is: " . Data::Dumper->new([$0])->Useqq(1)->Terse(1)->Dump; }; done_testing; Class-Accessor-Grouped-0.10012/t/illegal_name.t0000644000175000017500000000210012124441262020405 0ustar rabbitrabbituse Test::More; use Test::Exception; use strict; use warnings; use lib 't/lib'; use AccessorGroupsSubclass; { my $warned = 0; local $SIG{__WARN__} = sub { $_[0] =~ /unwise/ ? $warned++ : warn(@_) }; for (qw/DESTROY AUTOLOAD CLONE/) { AccessorGroupsSubclass->mk_group_accessors(warnings => $_); } is($warned, 3, 'Correct amount of unise warnings'); } if (eval { require Sub::Name } ) { my $warned = 0; local $SIG{__WARN__} = sub { $_[0] =~ /Installing illegal accessor/ ? $warned++ : warn(@_) }; for (qw/666_one 666_two/) { no warnings qw/once/; no strict 'refs'; local $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} = 1; AccessorGroupsSubclass->mk_group_accessors(warnings => $_); } is($warned, 1, 'Correct amount of illegal installation warnings'); }; throws_ok { AccessorGroupsSubclass->mk_group_accessors(simple => '2wrvwrv;') } qr/Illegal accessor name/; throws_ok { local $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} = 1; AccessorGroupsSubclass->mk_group_accessors(simple => "2wr\0vwrv;") } qr/nulls should never appear/; done_testing; Class-Accessor-Grouped-0.10012/t/inherited.t0000644000175000017500000000614112044165115017761 0ustar rabbitrabbituse Test::More tests => 36; use Test::Exception; use strict; use warnings; use lib 't/lib'; use SuperInheritedGroups; use NotHashBased; my $super = SuperInheritedGroups->new; my $base = BaseInheritedGroups->new; my @ret = SuperInheritedGroups->basefield; ok(@ret == 1, 'Return value before set'); ok(!defined(SuperInheritedGroups->basefield), 'Undef return before set'); # set base. base, super, object = base is(BaseInheritedGroups->basefield('All Your Base'), 'All Your Base'); is(SuperInheritedGroups->basefield, 'All Your Base'); is($super->basefield, 'All Your Base'); is($base->basefield, 'All Your Base'); # set super. super = super, base = base, object = super is(SuperInheritedGroups->basefield('Now Its Our Base'), 'Now Its Our Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); is($super->basefield, 'Now Its Our Base'); is($base->basefield, 'All Your Base'); #set base is($base->basefield('First Base'), 'First Base'); is($base->basefield, 'First Base'); is($super->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); # set object, object = object, super = super, base = base is($super->basefield('Third Base'), 'Third Base'); is($super->basefield, 'Third Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); # create new super. new = base, object = object, super = super, base = base my $newsuper = SuperInheritedGroups->new; is($newsuper->basefield, 'Now Its Our Base'); is($super->basefield, 'Third Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); # create new base. new = base, super = super, base = base my $newbase = BaseInheritedGroups->new; is($newbase->basefield, 'All Your Base'); is($newsuper->basefield, 'Now Its Our Base'); is($super->basefield, 'Third Base'); is(SuperInheritedGroups->basefield, 'Now Its Our Base'); is(BaseInheritedGroups->basefield, 'All Your Base'); # croak on get/set on non hash-based object my $dying = NotHashBased->new; throws_ok { $dying->killme; } qr/Cannot get.*is not hash-based/; throws_ok { $dying->killme('foo'); } qr/Cannot set.*is not hash-based/; # make sure we're get defined items, even 0, '' BaseInheritedGroups->basefield('base'); SuperInheritedGroups->basefield(0); is(SuperInheritedGroups->basefield, 0); BaseInheritedGroups->basefield('base'); SuperInheritedGroups->basefield(''); is(SuperInheritedGroups->basefield, ''); BaseInheritedGroups->basefield('base'); SuperInheritedGroups->basefield(undef); is(SuperInheritedGroups->basefield, 'base'); is(BaseInheritedGroups->undefined, undef); # make sure run-time @ISA changes trigger an inheritance chain recalculation SuperInheritedGroups->basefield(undef); BaseInheritedGroups->basefield('your base'); # dirty hack, emulate Class::C3::Componentised require ExtraInheritedGroups; unshift @SuperInheritedGroups::ISA, qw/ExtraInheritedGroups/; # this comes from ExtraInheritedGroups is(SuperInheritedGroups->basefield, 'your extra base!'); Class-Accessor-Grouped-0.10012/t/component.t0000644000175000017500000000162212044177472020020 0ustar rabbitrabbituse Test::More tests => 8; use Test::Exception; use strict; use warnings; use lib 't/lib'; use AccessorGroupsComp; is(AccessorGroupsComp->result_class, undef); ## 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'); } qr/Could not load result_class 'NotReallyAClass'/; is($dying->result_class, undef); ## don't croak when the class isn't available but not loaded for people ## who create class/packages on the fly $dying->result_class('JunkiesNeverInstalled'); is($dying->result_class, 'JunkiesNeverInstalled'); ok(! $INC{'BaseInheritedGroups.pm'}); AccessorGroupsComp->result_class('BaseInheritedGroups'); ok($INC{'BaseInheritedGroups.pm'}); is(AccessorGroupsComp->result_class, 'BaseInheritedGroups'); ## unset it AccessorGroupsComp->result_class(undef); is(AccessorGroupsComp->result_class, undef); Class-Accessor-Grouped-0.10012/t/accessors_wo.t0000644000175000017500000000377012411242035020500 0ustar rabbitrabbituse Test::More; use Test::Exception; use strict; use warnings; no warnings 'once'; use lib 't/lib'; # we test the pure-perl versions only, but allow overrides # from the accessor_xs test-umbrella # Also make sure a rogue envvar will not interfere with # 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; }; use AccessorGroupsWO; my $obj = AccessorGroupsWO->new; { my $warned = 0; local $SIG{__WARN__} = sub { if (shift =~ /DESTROY/i) { $warned++; }; }; no warnings qw/once/; local *AccessorGroupsWO::DESTROY = sub {}; $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", }, fieldname_torture => { custom_field => join ('', map { chr($_) } (0..255) ), is_xs => $use_xs, }, }; for my $name (sort keys %$test_accessors) { my $alias = "_${name}_accessor"; my $field = $test_accessors->{$name}{custom_field} || $name; can_ok($obj, $name, $alias); ok(!$obj->can($field)) if $field ne $name; # 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'); my $wo_regex = $test_accessors->{$name}{is_xs} ? qr/Usage\:.+$name.*\(self, newvalue\)/ : qr/$name(:?_accessor)?\Q' cannot access its value (write-only attribute of class AccessorGroupsWO)/ ; # die on get via name/alias SKIP: { skip "Class::XSAccessor emits broken error messages on 5.10 and earlier", 1 if ( $test_accessors->{$name}{is_xs} and $] < '5.011' ); throws_ok { $obj->$name; } $wo_regex; throws_ok { $obj->$alias; } $wo_regex; } }; done_testing unless $::SUBTESTING; Class-Accessor-Grouped-0.10012/t/warnings.t0000644000175000017500000000205712044165115017640 0ustar rabbitrabbituse strict; use warnings; BEGIN { 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}; 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 ); 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); return if $name =~ /TestApp/; if ($name =~ /\.(pm|pl|t)$/i && !exists($trusted{$file})) { push @files, $name; }; }; if (scalar @files) { plan tests => scalar @files; } else { plan tests => 1; fail 'No perl files found for Test::Strict checks!'; }; foreach (@files) { warnings_ok($_); }; Class-Accessor-Grouped-0.10012/t/manifest.t0000644000175000017500000000067712044165115017624 0ustar rabbitrabbituse strict; use warnings; BEGIN { use lib 't/lib'; use Test::More; 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'; }; }; ok_manifest({ exclude => ['/t/var', '/cover_db'], filter => [qr/\.(svn|git)/, qr/cover/, qr/Build(.(PL|bat))?/, qr/_build/, qr/\.DS_Store/], bool => 'or' }); Class-Accessor-Grouped-0.10012/t/accessors_xs.t0000644000175000017500000000431312412053266020506 0ustar rabbitrabbitmy $has_threads; BEGIN { eval ' use 5.008005; # older perls segfault on threading under CXSA use threads; use threads::shared; $has_threads = 1; ' } use strict; use warnings; no warnings 'once'; use FindBin qw($Bin); use File::Spec::Functions; use File::Spec::Unix (); # need this for %INC munging use Test::More; use lib 't/lib'; BEGIN { plan skip_all => "Sub::Name not available" unless eval { require Sub::Name }; 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 our $SUBTESTING = 1; $Class::Accessor::Grouped::USE_XS = 1; for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) { my $pass = 1; share($pass) if $has_threads; my $todo = sub { note "\nTesting $tname with USE_XS (pass @{[ $pass++ ]})\n\n"; my ($tfn) = catfile($Bin, $tname) =~ /(.+)/; for ( qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsParent.pm AccessorGroupsWO.pm|, File::Spec::Unix->catfile ($tfn), ) { delete $INC{$_}; no strict 'refs'; if (my ($mod) = $_ =~ /(.+)\.pm$/ ) { %{"${mod}::"} = (); } } local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i }; do($tfn); 666; }; if ($has_threads) { for (1,2) { is ( threads->create(sub { # nested threading of this sort badly blows up on 5.10.0 (fixed with 5.10.1) unless ($] > 5.009 and $] < 5.010001) { is ( threads->create(sub { $todo->(); })->join, 666, 'Innner thread joined ok', ); is ($todo->(), 666, "Intermediate result ok"); } return 777; })->join, 777, 'Outer thread joined ok', ); is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } else { is ($todo->(), 666, "Unthreaded run ok") for (1,2); } } done_testing; Class-Accessor-Grouped-0.10012/inc/0000755000175000017500000000000012414333163016126 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/inc/Module/0000755000175000017500000000000012414333163017353 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/inc/Module/Install.pm0000644000175000017500000003013512414333144021320 0ustar rabbitrabbit#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Class-Accessor-Grouped-0.10012/inc/Module/Install/0000755000175000017500000000000012414333163020761 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416212414333145023561 0ustar rabbitrabbit#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Class-Accessor-Grouped-0.10012/inc/Module/Install/Makefile.pm0000644000175000017500000002743712414333144023050 0ustar rabbitrabbit#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Class-Accessor-Grouped-0.10012/inc/Module/Install/Include.pm0000644000175000017500000000101512414333145022677 0ustar rabbitrabbit#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Class-Accessor-Grouped-0.10012/inc/Module/Install/Metadata.pm0000644000175000017500000004327712414333144023053 0ustar rabbitrabbit#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Class-Accessor-Grouped-0.10012/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612414333145023052 0ustar rabbitrabbit#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Class-Accessor-Grouped-0.10012/inc/Module/Install/Win32.pm0000644000175000017500000000340312414333145022221 0ustar rabbitrabbit#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Class-Accessor-Grouped-0.10012/inc/Module/Install/Fetch.pm0000644000175000017500000000462712414333145022361 0ustar rabbitrabbit#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Class-Accessor-Grouped-0.10012/inc/Module/Install/Base.pm0000644000175000017500000000214712414333144022174 0ustar rabbitrabbit#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Class-Accessor-Grouped-0.10012/inc/Module/Install/Can.pm0000644000175000017500000000615712414333144022030 0ustar rabbitrabbit#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Class-Accessor-Grouped-0.10012/inc/Module/AutoInstall.pm0000644000175000017500000006216212414333145022157 0ustar rabbitrabbit#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1193 Class-Accessor-Grouped-0.10012/Changes0000644000175000017500000001411412414333035016647 0ustar rabbitrabbitRevision history for Class::Accessor::Grouped. 0.10012 2014-10-05 21:22 (UTC) - Fix tests tickling deficient threads on perl 5.10.0 0.10011 2014-09-26 11:24 (UTC) - Soft-depend on newer (bugfixed and *simpler*) Class::XSAccessor 1.19 - More robust threading tests 0.10010 2013-04-24 02:58 (UTC) - Fix bug with identically-named 'simple' accessors in different classes set to access *differently named fields* getting their field access mixed up - Fix subtle pessimization when having identically-named accessors in different classes leads to 'simple' implementations not being replaced by Class::XSAccessor where appropriate 0.10009 2012-11-15 18:51 (UTC) - Stop leaking extra methods into the inheritance chain - there are plenty already 0.10008 2012-11-15 09:48 (UTC) - Allow disabling of accessor name checking introduced in 0.10007 - Pass tests if Class::XSAccessor is available but Sub::Name isn't 0.10007 2012-11-08 11:54 (UTC) - Disable tests on perls where Class::XSAccessor emits broken error messages (RT#74883, RT#80519) - Drop minimum perl to 5.6 (from 5.6.2) - Switch all module loading to Module::Runtime and lose dependency on Class::Inspector - Fix stupid mistake causing double-require of Sub::Name when Class::XSAccessor is not available (RT#80657) - Simplify superclass traversal done by the 'inherited' group type - Fix incorrect quoting of unusual hash keys (fieldnames) - Depend on newer bugfixed Class::XSAccessor 1.15 - Improve text of ro/wo violation exceptions - Sanity-check accessor names for well-formedness (qr/[A-Z_a-z][0-9A-Z_a-z]*/) 0.10006 2011-12-30 03:52 (UTC) - Silence warnings resulting from incomplete can() overrides hiding get/set_simple methods 0.10005 2011-12-26 12:43 (UTC) - Depend on newer bugfixed Class::XSAccessor - Repack with correct metadata (RT#73100) 0.10004 2011-11-28 21:20 (UTC) - No longer leak internal __CAG* methods into the inheritable namespace 0.10003 2011-05-03 00:15 (UTC) - Only require MRO::Compat for older perls - Add SYNOPSIS - Add examples for methods that get used most often 0.10002 Sun Dec 19 05:23:44 2010 - Fix grave bug of XS-enabled simple accessors clobbering an existing 'around' overlay installed in the same method slot - Require bugfixed XSAccessor, remove Win32 caveat 0.10001 Sun Dec 12 03:17:05 2010 - Fix an ActiveState Win32 incompatibility - Fix spurious method re-invocation warnings after Class::Unload 0.10000 Sat Nov 27 17:51:04 2010 - Fix perl 5.6 failures - Add test-time deferred coderef reinvocation checks - Another minor (8%) speedup 0.09009 Fri Nov 26 01:31:56 2010 - Major cleanup and optimization of code (evaled coderef sharing) - Module can now operate in PurePerl environments with 100% compatibility (including proper naming of generated coderefs) 0.09008 Sun Oct 11 07:41:56 2010 - Put back a private undocumented method that the DBIC-CDBI compat layer relies on :( - Fix corner case segfaults with C::XSA and old 5.8 perls 0.09007 Sat Oct 9 10:22:56 2010 (DELETED) - Fix corner case when get/set_simple overrides are circumvented iff Class::XSAccessor is present 0.09006 Fri Sep 10 23:55:00 2010 - Fix bugs in ro/wo accessor generation when XSAccessor is being used - Better Class::XSAccessor usage control - introducing $ENV{CAG_USE_XS} and $Class::Accessor::Grouped::USE_XS 0.09005 Wed Sep 1 04:00:00 2010 - Again, remove Class::XSAccessor for Win32 sine it still breaks 0.09004 Wed Aug 11 04:23:15 2010 - Changed the way Class::XSAccessor is invoked if available (recommended by C::XSA author) - Modified internal cache names to avoid real accessor clashes - Some micro-optimizations for get_inherited - Fixed field names with a single quote in them (patch from Jason Plum) 0.09003 Fri Apr 23 23:00:19 2010 - use Class::XSAccessor if available for 'simple' accessors, except on MSWin32, with documentation 0.09002 Tue Oct 20 23:16:28 2009 - removing Class::XSAccessor usage for now 0.09001 Thu Oct 1 21:48:06 2009 - remove optional dep from Makefile.PL 0.09000 Sun Aug 23 20:08:09 2009 - release 0.08999_01 Tue July 7 22:06:21 2009 - Make _mk_group_accessors name the closures installed for Moose compat - Use Class::XSAccessor if available RT#45577 (Andy Grundman) 0.08003 Sat Mar 21 9:27:24 2009 - Fixed set_inherited under C3::Componentised: RT#43702, RIBASUSHI 0.08002 Mon Nov 17 20:27:22 2008 - Removed unnecessary code in get_simple: RT#40992, BUCHMULLER Norbert 0.08001 Wed Jan 09 19:35:34 2008 - Fixed Makefile.PL tests setting that was killing older installs 0.08000 Tue Jan 08 18:22:47 2008 - Bumped version for release. No changes oherwise. 0.07009_01 Fri Dec 28 18:08::00 2007 - Tweak code for pure speed while fixing performance issue when assigning @_ under Perl 5.10.0 0.07000 - Altered get_inherited to return undef rather than () when no value set for Class::Data::(Inheritable|Accessor) compatiblity - Fixed spelling test error - Added WriteAll/DIST/PREOP for README 0.06000 Fri May 11 22:00:26 2007 - get_super_paths now uses mro::get_linear_isa to DTRT under C3 0.05002 Fri May 11 20:46:16 2007 - killed Class::Inspector->installed warnings 0.05001 Thur May 10 20:55:11 2007 - set_component_class now only dies if the specified class is a installed/installable class and fails to load it. 0.05000 Tue May 08 19:42:33 2007 - Added get/set_component_class 0 04000 Sat May 05 21:17:23 2007 - Converted to Module::Install - Added culterific tests/TEST_AUTHOR - Converted to distro friendly version number 0.03 2006-11-07 21:33::35 - big speedup for get_inherited - get_inherited now checks the current class first before calculating super_path - get_inherited now caches super_path results 0.02 2006-06-26 19:23:13 - Added return statement to end of get_inherited - Fixed pod NAME 0.01 2006-06-26 17:38:23 - initial release Class-Accessor-Grouped-0.10012/MANIFEST0000644000175000017500000000175112414333153016511 0ustar rabbitrabbitChanges inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Class/Accessor/Grouped.pm Makefile.PL MANIFEST This list of files META.yml README t/accessors.t t/accessors_pp.t t/accessors_ro.t t/accessors_wo.t t/accessors_xs.t t/accessors_xs_cachedwarn.t t/basic.t t/clean_namespace.t t/component.t t/illegal_name.t t/inherited.t t/lib/AccessorGroups.pm t/lib/AccessorGroupsComp.pm t/lib/AccessorGroupsParent.pm t/lib/AccessorGroupsRO.pm t/lib/AccessorGroupsSubclass.pm t/lib/AccessorGroupsWO.pm t/lib/BaseInheritedGroups.pm t/lib/ExtraInheritedGroups.pm t/lib/NotHashBased.pm t/lib/NotReallyAClass.pm t/lib/SuperInheritedGroups.pm t/manifest.t t/pod_coverage.t t/pod_spelling.t t/pod_syntax.t t/strict.t t/style_no_tabs.t t/warnings.t Class-Accessor-Grouped-0.10012/META.yml0000644000175000017500000000145112414333145016627 0ustar rabbitrabbit--- abstract: 'Lets you build groups of accessors' author: - 'Matt S. Trout ' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0.31 Test::More: 0.88 configure_requires: ExtUtils::CBuilder: 0.27 ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Class-Accessor-Grouped no_index: directory: - inc - t recommends: Class::XSAccessor: 1.19 Sub::Name: 0.05 requires: Carp: 0 Module::Runtime: 0.012 Scalar::Util: 0 perl: 5.6.0 resources: license: http://dev.perl.org/licenses/ repository: git://git.shadowcat.co.uk/p5sagit/Class-Accessor-Grouped.git version: 0.10012 Class-Accessor-Grouped-0.10012/lib/0000755000175000017500000000000012414333163016123 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/lib/Class/0000755000175000017500000000000012414333163017170 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/lib/Class/Accessor/0000755000175000017500000000000012414333163020732 5ustar rabbitrabbitClass-Accessor-Grouped-0.10012/lib/Class/Accessor/Grouped.pm0000644000175000017500000007126512414333002022700 0ustar rabbitrabbitpackage Class::Accessor::Grouped; use strict; use warnings; use Carp (); use Scalar::Util (); use Module::Runtime (); BEGIN { # use M::R to work around the 5.8 require bugs if ($] < 5.009_005) { Module::Runtime::require_module('MRO::Compat'); } else { require mro; } } our $VERSION = '0.10012'; $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases # when changing minimum version don't forget to adjust Makefile.PL as well our $__minimum_xsa_version; BEGIN { $__minimum_xsa_version = '1.19' } our $USE_XS; # 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; BEGIN { package # hide from PAUSE __CAG_ENV__; die "Huh?! No minimum C::XSA version?!\n" unless $__minimum_xsa_version; local $@; require constant; # individual (one const at a time) imports so we are 5.6.2 compatible # if we can - why not ;) constant->import( NO_SUBNAME => eval { Module::Runtime::require_module('Sub::Name') } ? 0 : "$@" ); my $found_cxsa; constant->import( NO_CXSA => ( NO_SUBNAME() || ( eval { Module::Runtime::require_module('Class::XSAccessor'); $found_cxsa = Class::XSAccessor->VERSION; Class::XSAccessor->VERSION($__minimum_xsa_version); } ? 0 : "$@" ) ) ); if (NO_CXSA() and $found_cxsa and !$ENV{CAG_OLD_XS_NOWARN}) { warn( 'The installed version of Class::XSAccessor is too old ' . "(v$found_cxsa < v$__minimum_xsa_version). Please upgrade " . "to instantly quadruple the performance of 'simple' accessors. " . 'Set $ENV{CAG_OLD_XS_NOWARN} if you wish to disable this ' . "warning.\n" ); } constant->import( BROKEN_GOTO => ($] < '5.008009') ? 1 : 0 ); constant->import( UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0 ); constant->import( TRACK_UNDEFER_FAIL => ( $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'} and $0 =~ m{ ^ (?: \. \/ )? x?t / .+ \.t $}x ) ? 1 : 0 ); sub perlstring ($) { q{"}. quotemeta( shift ). q{"} }; } # 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 # %$*@!?&!&#*$!!! my $illegal_accessors_warned; sub _mk_group_accessors { my($self, $maker, $group, @fields) = @_; my $class = length (ref ($self) ) ? ref ($self) : $self; 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; for (@fields) { my ($name, $field) = (ref $_) ? (@$_) : ($_, $_); if ($name !~ /\A[A-Z_a-z][0-9A-Z_a-z]*\z/) { if ($name =~ /\0/) { Carp::croak(sprintf "Illegal accessor name %s - nulls should never appear in stash keys", __CAG_ENV__::perlstring($name), ); } elsif (! $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ) { Carp::croak( "Illegal accessor name '$name'. If you want CAG to attempt creating " . 'it anyway (possible if Sub::Name is available) set ' . '$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}' ); } elsif (__CAG_ENV__::NO_SUBNAME) { Carp::croak( "Unable to install accessor with illegal name '$name': " . 'Sub::Name not available' ); } elsif ( # Because one of the former maintainers of DBIC::SL is a raging # idiot, there is now a ton of DBIC code out there that attempts # to create column accessors with illegal names. In the interest # of not cluttering the logs of unsuspecting victims (unsuspecting # because these accessors are unusable anyway) we provide an # explicit "do not warn at all" escape, until all such code is # fixed (this will be a loooooong time >:( $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ne 'DO_NOT_WARN' and ! $illegal_accessors_warned->{$class}++ ) { Carp::carp( "Installing illegal accessor '$name' into $class, see " . 'documentation for more details' ); } } Carp::carp("Having a data accessor named '$name' in '$class' is unwise.") if $name =~ /\A(?: DESTROY | AUTOLOAD | CLONE )\z/x; my $alias = "_${name}_accessor"; for ($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, $_) or next; my $fq_meth = "${class}::$_"; *$fq_meth = Sub::Name::subname($fq_meth, $cref); #unless defined &{$class."\:\:$field"} } } }; # $gen_accessor coderef is setup at the end for clarity my $gen_accessor; =head1 NAME Class::Accessor::Grouped - Lets you build groups of accessors =head1 SYNOPSIS use base 'Class::Accessor::Grouped'; # make basic accessors for objects __PACKAGE__->mk_group_accessors(simple => qw(id name email)); # make accessor that works for objects and classes __PACKAGE__->mk_group_accessors(inherited => 'awesome_level'); # make an accessor which calls a custom pair of getters/setters sub get_column { ... this will be called when you do $obj->name() ... } sub set_column { ... this will be called when you do $obj->name('foo') ... } __PACKAGE__->mk_group_accessors(column => 'name'); =head1 DESCRIPTION This class lets you build groups of accessors that will call different getters and setters. The documentation of this module still requires a lot of work (B<< volunteers welcome >.> >>), but in the meantime you can refer to L for more information. =head2 Notes on accessor names In general method names in Perl are considered identifiers, and as such need to conform to the identifier specification of C. While it is rather easy to invoke methods with non-standard names (C<< $obj->${\"anything goes"} >>), it is not possible to properly declare such methods without the use of L. Since this module must be able to function identically with and without its optional dependencies, starting with version C<0.10008> attempting to declare an accessor with a non-standard name is a fatal error (such operations would silently succeed since version C<0.08004>, as long as L is present, or otherwise would result in a syntax error during a string eval). Unfortunately in the years since C<0.08004> a rather large body of code accumulated in the wild that does attempt to declare accessors with funny names. One notable perpetrator is L, which under certain conditions could create accessors of the C group which start with numbers and/or some other punctuation (the proper way would be to declare columns with the C attribute set to C). Therefore an escape mechanism is provided via the environment variable C. When set to a true value, one warning is issued B on attempts to declare an accessor with a non-conforming name, and as long as L is available all accessors will be properly created. Regardless of this setting, accessor names containing nulls C<"\0"> are disallowed, due to various deficiencies in perl itself. If your code base has too many instances of illegal accessor declarations, and a fix is not feasible due to time constraints, it is possible to disable the warnings altogether by setting C<$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}> to C (observe capitalization). =head1 METHODS =head2 mk_group_accessors __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]); =over 4 =item Arguments: $group, @fieldspec Returns: none =back Creates a set of accessors in a given group. $group is the name of the accessor group for the generated accessors; they will call get_$group($field) on get and set_$group($field, $value) on set. If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple' to tell Class::Accessor::Grouped to use its own get_simple and set_simple methods. @fieldspec is a list of field/accessor names; if a fieldspec is a scalar this is used as both field and accessor name, if a listref it is expected to be of the form [ $accessor, $field ]. =cut sub mk_group_accessors { my ($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_accessor', $group, @fields); return; } =head2 mk_group_ro_accessors __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]); =over 4 =item Arguments: $group, @fieldspec Returns: none =back Creates a set of read only accessors in a given group. Identical to L but accessors will throw an error if passed a value rather than setting the value. =cut sub mk_group_ro_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields); return; } =head2 mk_group_wo_accessors __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]); =over 4 =item Arguments: $group, @fieldspec Returns: none =back Creates a set of write only accessors in a given group. Identical to L but accessors will throw an error if not passed a value rather than getting the value. =cut sub mk_group_wo_accessors { my($self, $group, @fields) = @_; $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields); return; } =head2 get_simple =over 4 =item Arguments: $field Returns: $value =back Simple getter for hash-based objects which returns the value for the field name passed as an argument. =cut sub get_simple { $_[0]->{$_[1]}; } =head2 set_simple =over 4 =item Arguments: $field, $new_value Returns: $new_value =back Simple setter for hash-based objects which sets and then returns the value for the field name passed as an argument. =cut sub set_simple { $_[0]->{$_[1]} = $_[2]; } =head2 get_inherited =over 4 =item Arguments: $field Returns: $value =back Simple getter for Classes and hash-based objects which returns the value for the field name passed as an argument. This behaves much like L where the field can be set in a base class, inherited and changed in subclasses, and inherited and changed for object instances. =cut sub get_inherited { if ( length (ref ($_[0]) ) ) { if (Scalar::Util::reftype $_[0] eq 'HASH') { return $_[0]->{$_[1]} if exists $_[0]->{$_[1]}; # everything in @_ is aliased, an assignment won't work splice @_, 0, 1, ref($_[0]); } else { Carp::croak('Cannot get inherited value on an object instance that is not hash-based'); } } # if we got this far there is nothing in the instance # OR this is a class call # in any case $_[0] contains the class name (see splice above) no strict 'refs'; no warnings 'uninitialized'; my $cag_slot = '::__cag_'. $_[1]; return ${$_[0].$cag_slot} if defined(${$_[0].$cag_slot}); do { return ${$_.$cag_slot} if defined(${$_.$cag_slot}) } for $_[0]->get_super_paths; return undef; } =head2 set_inherited =over 4 =item Arguments: $field, $new_value Returns: $new_value =back Simple setter for Classes and hash-based objects which sets and then returns the value for the field name passed as an argument. When called on a hash-based object it will set the appropriate hash key value. When called on a class, it will set a class level variable. B: This method will die if you try to set an object variable on a non hash-based object. =cut sub set_inherited { if (length (ref ($_[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'); }; } no strict 'refs'; ${$_[0].'::__cag_'.$_[1]} = $_[2]; } =head2 get_component_class =over 4 =item Arguments: $field Returns: $value =back Gets the value of the specified component class. __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); $self->result_class->method(); ## same as $self->get_component_class('result_class')->method(); =cut sub get_component_class { $_[0]->get_inherited($_[1]); }; =head2 set_component_class =over 4 =item Arguments: $field, $class Returns: $new_value =back 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'); $self->result_class->method(); =cut sub set_component_class { if (defined $_[2] and length $_[2]) { # disable warnings, and prevent $_ being eaten away by a behind-the-scenes # module loading local ($^W, $_); if (__CAG_ENV__::UNSTABLE_DOLLARAT) { my $err; { local $@; eval { Module::Runtime::use_package_optimistically($_[2]) } or $err = $@; } Carp::croak("Could not load $_[1] '$_[2]': $err") if defined $err; } else { eval { Module::Runtime::use_package_optimistically($_[2]) } or Carp::croak("Could not load $_[1] '$_[2]': $@"); } }; $_[0]->set_inherited($_[1], $_[2]); }; =head1 INTERNAL METHODS These methods are documented for clarity, but are never meant to be called directly, and are not really meant for overriding either. =head2 get_super_paths Returns a list of 'parent' or 'super' class names that the current class inherited from. This is what drives the traversal done by L. =cut sub get_super_paths { # get_linear_isa returns the class itself as the 1st element # use @_ as a pre-allocated scratch array (undef, @_) = @{mro::get_linear_isa( length( ref($_[0]) ) ? ref($_[0]) : $_[0] )}; @_; }; =head2 make_group_accessor __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length'); __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color'); =over 4 =item Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? =back Called by mk_group_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns C if it elects to install the coderef on its own. =cut sub make_group_accessor { $gen_accessor->('rw', @_) } =head2 make_group_ro_accessor __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate'); __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number'); =over 4 =item Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? =back Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns C if it elects to install the coderef on its own. =cut sub make_group_ro_accessor { $gen_accessor->('ro', @_) } =head2 make_group_wo_accessor __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie'); __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject'); =over 4 =item Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? =back Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns C if it elects to install the coderef on its own. =cut sub make_group_wo_accessor { $gen_accessor->('wo', @_) } =head1 PERFORMANCE To provide total flexibility L calls methods internally while performing get/set actions, which makes it noticeably slower than similar modules. To compensate, this module will automatically use the insanely fast L to generate the C-group accessors if this module is available on your system. =head2 Benchmark This is the benchmark of 200 get/get/set/get/set cycles on perl 5.16.2 with thread support, showcasing how this modules L, L and L accessors stack up against most popular accessor builders: L, L, L, L (both pure-perl and XS variant), L, L, L, L, L and L Rate CAG_INHP CAG_INH CA CAG_S CAF moOse OTRW CAL mo moUse HANDMADE moo CAF_XS moUse_XS XSA CAG_INHP 287.021+-0.02/s -- -0.3% -10.0% -37.1% -53.1% -53.6% -53.7% -54.1% -56.9% -59.0% -59.6% -59.8% -78.7% -81.9% -83.5% CAG_INH 288.025+-0.031/s 0.3% -- -9.7% -36.9% -52.9% -53.5% -53.5% -53.9% -56.7% -58.8% -59.5% -59.7% -78.6% -81.9% -83.5% CA 318.967+-0.047/s 11.1% 10.7% -- -30.1% -47.9% -48.5% -48.5% -49.0% -52.1% -54.4% -55.1% -55.3% -76.3% -79.9% -81.7% CAG_S 456.107+-0.054/s 58.9% 58.4% 43.0% -- -25.4% -26.3% -26.4% -27.0% -31.5% -34.8% -35.8% -36.1% -66.1% -71.3% -73.9% CAF 611.745+-0.099/s 113.1% 112.4% 91.8% 34.1% -- -1.2% -1.2% -2.1% -8.1% -12.6% -14.0% -14.3% -54.5% -61.5% -64.9% moOse 619.051+-0.059/s 115.7% 114.9% 94.1% 35.7% 1.2% -- -0.1% -1.0% -7.0% -11.6% -12.9% -13.3% -54.0% -61.0% -64.5% OTRW 619.475+-0.1/s 115.8% 115.1% 94.2% 35.8% 1.3% 0.1% -- -0.9% -6.9% -11.5% -12.9% -13.2% -54.0% -61.0% -64.5% CAL 625.106+-0.085/s 117.8% 117.0% 96.0% 37.1% 2.2% 1.0% 0.9% -- -6.1% -10.7% -12.1% -12.5% -53.5% -60.6% -64.2% mo 665.44+-0.12/s 131.8% 131.0% 108.6% 45.9% 8.8% 7.5% 7.4% 6.5% -- -4.9% -6.4% -6.8% -50.5% -58.1% -61.9% moUse 699.9+-0.15/s 143.9% 143.0% 119.4% 53.5% 14.4% 13.1% 13.0% 12.0% 5.2% -- -1.6% -2.0% -48.0% -55.9% -59.9% HANDMADE 710.98+-0.16/s 147.7% 146.8% 122.9% 55.9% 16.2% 14.9% 14.8% 13.7% 6.8% 1.6% -- -0.4% -47.2% -55.2% -59.2% moo 714.04+-0.13/s 148.8% 147.9% 123.9% 56.6% 16.7% 15.3% 15.3% 14.2% 7.3% 2.0% 0.4% -- -46.9% -55.0% -59.1% CAF_XS 1345.55+-0.051/s 368.8% 367.2% 321.8% 195.0% 120.0% 117.4% 117.2% 115.3% 102.2% 92.2% 89.3% 88.4% -- -15.3% -22.9% moUse_XS 1588+-0.036/s 453.3% 451.3% 397.9% 248.2% 159.6% 156.5% 156.3% 154.0% 138.6% 126.9% 123.4% 122.4% 18.0% -- -9.0% XSA 1744.67+-0.052/s 507.9% 505.7% 447.0% 282.5% 185.2% 181.8% 181.6% 179.1% 162.2% 149.3% 145.4% 144.3% 29.7% 9.9% -- Benchmarking program is available in the root of the L: =head2 Notes on Class::XSAccessor You can force (or disable) the use of L before creating a particular C accessor by either manipulating the global variable C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with L, or you can do so before runtime via the C environment variable. Since L has no knowledge of L and L this module does its best to detect if you are overriding one of these methods and will fall back to using the perl version of the accessor in order to maintain consistency. However be aware that if you enable use of C (automatically or explicitly), create an object, invoke a simple accessor on that object, and B manipulate the symbol table to install a C override - you get to keep all the pieces. =head1 AUTHORS Matt S. Trout Christopher H. Laco =head1 CONTRIBUTORS Caelum: Rafael Kitover frew: Arthur Axel "fREW" Schmidt groditi: Guillermo Roditi Jason Plum ribasushi: Peter Rabbitson =head1 COPYRIGHT & LICENSE Copyright (c) 2006-2010 Matt S. Trout This program is free software; you can redistribute it and/or modify it under the same terms as perl itself. =cut ######################################################################## ######################################################################## ######################################################################## # # Here be many angry dragons # (all code is in private coderefs since everything inherits CAG) # ######################################################################## ######################################################################## # Autodetect unless flag supplied my $xsa_autodetected; if (! defined $USE_XS) { $USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1; $xsa_autodetected++; } my $maker_templates = { rw => { cxsa_call => 'accessors', pp_generator => sub { # my ($group, $fieldname) = @_; my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]); sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2; @_ > 1 ? shift->set_%s(%s, @_) : shift->get_%s(%s) EOS }, }, ro => { cxsa_call => 'getters', pp_generator => sub { # my ($group, $fieldname) = @_; my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]); sprintf <<'EOS', $_[0], $quoted_fieldname; @_ > 1 ? do { my ($meth) = (caller(0))[3] =~ /([^\:]+)$/; my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0]; Carp::croak( "'$meth' cannot alter its value (read-only attribute of class $class)" ); } : shift->get_%s(%s) EOS }, }, wo => { cxsa_call => 'setters', pp_generator => sub { # my ($group, $fieldname) = @_; my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]); sprintf <<'EOS', $_[0], $quoted_fieldname; @_ > 1 ? shift->set_%s(%s, @_) : do { my ($meth) = (caller(0))[3] =~ /([^\:]+)$/; my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0]; Carp::croak( "'$meth' cannot access its value (write-only attribute of class $class)" ); } EOS }, }, }; my $cag_eval = sub { #my ($src, $no_warnings, $err_msg) = @_; my $src = sprintf "{ %s warnings; use strict; no strict 'refs'; %s }", $_[1] ? 'no' : 'use', $_[0], ; my (@rv, $err); { local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT; wantarray ? @rv = eval $src : $rv[0] = eval $src ; $err = $@ if $@ ne ''; } Carp::croak(join ': ', ($_[2] || 'String-eval failed'), "$err\n$src\n" ) if defined $err; wantarray ? @rv : $rv[0]; }; my ($accessor_maker_cache, $no_xsa_warned_classes); # can't use pkg_gen to track this stuff, as it doesn't # detect superclass mucking my $original_simple_getter = __PACKAGE__->can ('get_simple'); my $original_simple_setter = __PACKAGE__->can ('set_simple'); my ($resolved_methods, $cag_produced_crefs); sub CLONE { my @crefs = grep { defined $_ } values %{$cag_produced_crefs||{}}; $cag_produced_crefs = @crefs ? { map { $_ => $_ } @crefs } : undef ; } # Note!!! Unusual signature $gen_accessor = sub { my ($type, $class, $group, $field, $methname) = @_; $class = ref $class if length ref $class; # When installing an XSA simple accessor, we need to make sure we are not # short-circuiting a (compile or runtime) get_simple/set_simple override. # What we do here is install a lazy first-access check, which will decide # the ultimate coderef being placed in the accessor slot # # Also note that the *original* class will always retain this shim, as # different branches inheriting from it may have different overrides. # Thus the final method (properly labeled and all) is installed in the # calling-package's namespace if ($USE_XS and $group eq 'simple') { die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA ) if __CAG_ENV__::NO_CXSA; my $ret = sub { my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0]; my $resolved_implementation = $resolved_methods->{$current_class}{$methname} ||= do { if ( ($current_class->can('get_simple')||0) == $original_simple_getter && ($current_class->can('set_simple')||0) == $original_simple_setter ) { # nothing has changed, might as well use the XS crefs # # note that by the time this code executes, we already have # *objects* (since XSA works on 'simple' only by definition). # If someone is mucking with the symbol table *after* there # are some objects already - look! many, shiny pieces! :) # # The weird breeder thingy is because XSA does not have an # interface returning *just* a coderef, without installing it # anywhere :( Class::XSAccessor->import( replace => 1, class => '__CAG__XSA__BREEDER__', $maker_templates->{$type}{cxsa_call} => { $methname => $field, }, ); __CAG__XSA__BREEDER__->can($methname); } else { if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) { # not using Carp since the line where this happens doesn't mean much warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class ' . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or " . "set_simple\n"; } do { # that's faster than local $USE_XS = 0; my $c = $gen_accessor->($type, $class, 'simple', $field, $methname); $USE_XS = 1; $c; }; } }; # if after this shim was created someone wrapped it with an 'around', # we can not blindly reinstall the method slot - we will destroy the # wrapper. Silently chain execution further... if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) { # older perls segfault if the cref behind the goto throws # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO; goto $resolved_implementation; } if (__CAG_ENV__::TRACK_UNDEFER_FAIL) { my $deferred_calls_seen = do { no strict 'refs'; \%{"${current_class}::__cag_deferred_xs_shim_invocations"} }; my @cframe = caller(0); if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) { Carp::carp ( "Deferred version of method $cframe[3] invoked more than once (originally " . "invoked at $already_seen). This is a strong indication your code has " . 'cached the original ->can derived method coderef, and is using it instead ' . 'of the proper method re-lookup, causing minor performance regressions' ); } else { $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]"; } } # install the resolved implementation into the code slot so we do not # come here anymore (hopefully) # since XSAccessor was available - so is Sub::Name { no strict 'refs'; no warnings 'redefine'; my $fq_name = "${current_class}::${methname}"; *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation); } # now things are installed - one ref less to carry delete $resolved_methods->{$current_class}{$methname}; # but need to record it in the expectation registry *in case* it # was cached via ->can for some moronic reason Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation ); # older perls segfault if the cref behind the goto throws # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO; goto $resolved_implementation; }; Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret); $ret; # returning shim } # no Sub::Name - just install the coderefs directly (compiling every time) elsif (__CAG_ENV__::NO_SUBNAME) { my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||= $maker_templates->{$type}{pp_generator}->($group, $field); $cag_eval->( "no warnings 'redefine'; sub ${class}::${methname} { $src }; 1", ); undef; # so that no further attempt will be made to install anything } # a coderef generator with a variable pad (returns a fresh cref on every invocation) else { ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do { my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||= $maker_templates->{$type}{pp_generator}->($group, $field); $cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" ); })->() } }; 1; Class-Accessor-Grouped-0.10012/Makefile.PL0000644000175000017500000000253312411242056017327 0ustar rabbitrabbituse strict; use warnings; use inc::Module::Install 1.06; name 'Class-Accessor-Grouped'; license 'perl'; perl_version '5.006'; all_from 'lib/Class/Accessor/Grouped.pm'; requires 'Carp'; requires 'Module::Runtime' => '0.012'; requires 'Scalar::Util'; requires 'MRO::Compat' if $] < 5.009_005; my $recommends = { 'Sub::Name' => '0.05', # when changing CXSA version don't forget to adjust lib/Class/Accessor/Grouped.pm as well 'Class::XSAccessor' => '1.19', }; recommends( $_ => $recommends->{$_} ) for keys %$recommends; if (can_xs or $Module::Install::AUTHOR) { requires 'Sub::Name' => $recommends->{'Sub::Name'}; requires 'Class::XSAccessor' => $recommends->{'Class::XSAccessor'} if $] > '5.008'; # CXSA does not work on 5.6 } test_requires 'Test::More' => '0.88'; test_requires 'Test::Exception' => '0.31'; clean_files "Class-Accessor-Grouped-* t/var"; if (-e 'MANIFEST.SKIP') { system('pod2text lib/Class/Accessor/Grouped.pm > README'); realclean_files 'README'; } auto_install; resources repository => 'git://git.shadowcat.co.uk/p5sagit/Class-Accessor-Grouped.git'; WriteAll; if ($Module::Install::AUTHOR) { @{Meta->{values}{requires}} = grep { $_->[0] !~ /^ (?: Class\:\:XSAccessor | Sub\:\:Name | MRO\:\:Compat ) $/x } @{Meta->{values}{requires}} ; print "Regenerating META with XS requires excluded\n"; Meta->write; } Class-Accessor-Grouped-0.10012/README0000644000175000017500000003122212414333145016235 0ustar rabbitrabbitNAME Class::Accessor::Grouped - Lets you build groups of accessors SYNOPSIS use base 'Class::Accessor::Grouped'; # make basic accessors for objects __PACKAGE__->mk_group_accessors(simple => qw(id name email)); # make accessor that works for objects and classes __PACKAGE__->mk_group_accessors(inherited => 'awesome_level'); # make an accessor which calls a custom pair of getters/setters sub get_column { ... this will be called when you do $obj->name() ... } sub set_column { ... this will be called when you do $obj->name('foo') ... } __PACKAGE__->mk_group_accessors(column => 'name'); DESCRIPTION This class lets you build groups of accessors that will call different getters and setters. The documentation of this module still requires a lot of work (volunteers welcome >.>), but in the meantime you can refer to this post for more information. Notes on accessor names In general method names in Perl are considered identifiers, and as such need to conform to the identifier specification of "qr/\A[A-Z_a-z][0-9A-Z_a-z]*\z/". While it is rather easy to invoke methods with non-standard names ("$obj->${\"anything goes"}"), it is not possible to properly declare such methods without the use of Sub::Name. Since this module must be able to function identically with and without its optional dependencies, starting with version 0.10008 attempting to declare an accessor with a non-standard name is a fatal error (such operations would silently succeed since version 0.08004, as long as Sub::Name is present, or otherwise would result in a syntax error during a string eval). Unfortunately in the years since 0.08004 a rather large body of code accumulated in the wild that does attempt to declare accessors with funny names. One notable perpetrator is DBIx::Class::Schema::Loader, which under certain conditions could create accessors of the "column" group which start with numbers and/or some other punctuation (the proper way would be to declare columns with the "accessor" attribute set to "undef"). Therefore an escape mechanism is provided via the environment variable "CAG_ILLEGAL_ACCESSOR_NAME_OK". When set to a true value, one warning is issued per class on attempts to declare an accessor with a non-conforming name, and as long as Sub::Name is available all accessors will be properly created. Regardless of this setting, accessor names containing nulls "\0" are disallowed, due to various deficiencies in perl itself. If your code base has too many instances of illegal accessor declarations, and a fix is not feasible due to time constraints, it is possible to disable the warnings altogether by setting $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} to "DO_NOT_WARN" (observe capitalization). METHODS mk_group_accessors __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]); Arguments: $group, @fieldspec Returns: none Creates a set of accessors in a given group. $group is the name of the accessor group for the generated accessors; they will call get_$group($field) on get and set_$group($field, $value) on set. If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple' to tell Class::Accessor::Grouped to use its own get_simple and set_simple methods. @fieldspec is a list of field/accessor names; if a fieldspec is a scalar this is used as both field and accessor name, if a listref it is expected to be of the form [ $accessor, $field ]. mk_group_ro_accessors __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]); Arguments: $group, @fieldspec Returns: none Creates a set of read only accessors in a given group. Identical to "mk_group_accessors" but accessors will throw an error if passed a value rather than setting the value. mk_group_wo_accessors __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]); Arguments: $group, @fieldspec Returns: none Creates a set of write only accessors in a given group. Identical to "mk_group_accessors" but accessors will throw an error if not passed a value rather than getting the value. get_simple Arguments: $field Returns: $value Simple getter for hash-based objects which returns the value for the field name passed as an argument. set_simple Arguments: $field, $new_value Returns: $new_value Simple setter for hash-based objects which sets and then returns the value for the field name passed as an argument. get_inherited Arguments: $field Returns: $value Simple getter for Classes and hash-based objects which returns the value for the field name passed as an argument. This behaves much like Class::Data::Accessor where the field can be set in a base class, inherited and changed in subclasses, and inherited and changed for object instances. set_inherited Arguments: $field, $new_value Returns: $new_value Simple setter for Classes and hash-based objects which sets and then returns the value for the field name passed as an argument. When called on a hash-based object it will set the appropriate hash key value. When called on a class, it will set a class level variable. Note:: This method will die if you try to set an object variable on a non hash-based object. get_component_class Arguments: $field Returns: $value Gets the value of the specified component class. __PACKAGE__->mk_group_accessors('component_class' => 'result_class'); $self->result_class->method(); ## same as $self->get_component_class('result_class')->method(); set_component_class Arguments: $field, $class Returns: $new_value 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'); $self->result_class->method(); INTERNAL METHODS These methods are documented for clarity, but are never meant to be called directly, and are not really meant for overriding either. get_super_paths Returns a list of 'parent' or 'super' class names that the current class inherited from. This is what drives the traversal done by "get_inherited". make_group_accessor __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length'); __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color'); Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? Called by mk_group_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at "&__PACKAGE__::$accessor", or returns "undef" if it elects to install the coderef on its own. make_group_ro_accessor __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate'); __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number'); Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at "&__PACKAGE__::$accessor", or returns "undef" if it elects to install the coderef on its own. make_group_wo_accessor __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie'); __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject'); Arguments: $group, $field, $accessor Returns: \&accessor_coderef ? Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns a coderef which will be installed at "&__PACKAGE__::$accessor", or returns "undef" if it elects to install the coderef on its own. PERFORMANCE To provide total flexibility Class::Accessor::Grouped calls methods internally while performing get/set actions, which makes it noticeably slower than similar modules. To compensate, this module will automatically use the insanely fast Class::XSAccessor to generate the "simple"-group accessors if this module is available on your system. Benchmark This is the benchmark of 200 get/get/set/get/set cycles on perl 5.16.2 with thread support, showcasing how this modules simple (CAG_S), inherited (CAG_INH) and inherited with parent-class data (CAG_INHP) accessors stack up against most popular accessor builders: Moose, Moo, Mo, Mouse (both pure-perl and XS variant), Object::Tiny::RW (OTRW), Class::Accessor (CA), Class::Accessor::Lite (CAL), Class::Accessor::Fast (CAF), Class::Accessor::Fast::XS (CAF_XS) and Class::XSAccessor (XSA) Rate CAG_INHP CAG_INH CA CAG_S CAF moOse OTRW CAL mo moUse HANDMADE moo CAF_XS moUse_XS XSA CAG_INHP 287.021+-0.02/s -- -0.3% -10.0% -37.1% -53.1% -53.6% -53.7% -54.1% -56.9% -59.0% -59.6% -59.8% -78.7% -81.9% -83.5% CAG_INH 288.025+-0.031/s 0.3% -- -9.7% -36.9% -52.9% -53.5% -53.5% -53.9% -56.7% -58.8% -59.5% -59.7% -78.6% -81.9% -83.5% CA 318.967+-0.047/s 11.1% 10.7% -- -30.1% -47.9% -48.5% -48.5% -49.0% -52.1% -54.4% -55.1% -55.3% -76.3% -79.9% -81.7% CAG_S 456.107+-0.054/s 58.9% 58.4% 43.0% -- -25.4% -26.3% -26.4% -27.0% -31.5% -34.8% -35.8% -36.1% -66.1% -71.3% -73.9% CAF 611.745+-0.099/s 113.1% 112.4% 91.8% 34.1% -- -1.2% -1.2% -2.1% -8.1% -12.6% -14.0% -14.3% -54.5% -61.5% -64.9% moOse 619.051+-0.059/s 115.7% 114.9% 94.1% 35.7% 1.2% -- -0.1% -1.0% -7.0% -11.6% -12.9% -13.3% -54.0% -61.0% -64.5% OTRW 619.475+-0.1/s 115.8% 115.1% 94.2% 35.8% 1.3% 0.1% -- -0.9% -6.9% -11.5% -12.9% -13.2% -54.0% -61.0% -64.5% CAL 625.106+-0.085/s 117.8% 117.0% 96.0% 37.1% 2.2% 1.0% 0.9% -- -6.1% -10.7% -12.1% -12.5% -53.5% -60.6% -64.2% mo 665.44+-0.12/s 131.8% 131.0% 108.6% 45.9% 8.8% 7.5% 7.4% 6.5% -- -4.9% -6.4% -6.8% -50.5% -58.1% -61.9% moUse 699.9+-0.15/s 143.9% 143.0% 119.4% 53.5% 14.4% 13.1% 13.0% 12.0% 5.2% -- -1.6% -2.0% -48.0% -55.9% -59.9% HANDMADE 710.98+-0.16/s 147.7% 146.8% 122.9% 55.9% 16.2% 14.9% 14.8% 13.7% 6.8% 1.6% -- -0.4% -47.2% -55.2% -59.2% moo 714.04+-0.13/s 148.8% 147.9% 123.9% 56.6% 16.7% 15.3% 15.3% 14.2% 7.3% 2.0% 0.4% -- -46.9% -55.0% -59.1% CAF_XS 1345.55+-0.051/s 368.8% 367.2% 321.8% 195.0% 120.0% 117.4% 117.2% 115.3% 102.2% 92.2% 89.3% 88.4% -- -15.3% -22.9% moUse_XS 1588+-0.036/s 453.3% 451.3% 397.9% 248.2% 159.6% 156.5% 156.3% 154.0% 138.6% 126.9% 123.4% 122.4% 18.0% -- -9.0% XSA 1744.67+-0.052/s 507.9% 505.7% 447.0% 282.5% 185.2% 181.8% 181.6% 179.1% 162.2% 149.3% 145.4% 144.3% 29.7% 9.9% -- Benchmarking program is available in the root of the repository : Notes on Class::XSAccessor You can force (or disable) the use of Class::XSAccessor before creating a particular "simple" accessor by either manipulating the global variable $Class::Accessor::Grouped::USE_XS to true or false (preferably with localization, or you can do so before runtime via the "CAG_USE_XS" environment variable. Since Class::XSAccessor has no knowledge of "get_simple" and "set_simple" this module does its best to detect if you are overriding one of these methods and will fall back to using the perl version of the accessor in order to maintain consistency. However be aware that if you enable use of "Class::XSAccessor" (automatically or explicitly), create an object, invoke a simple accessor on that object, and then manipulate the symbol table to install a "get/set_simple" override - you get to keep all the pieces. AUTHORS Matt S. Trout Christopher H. Laco CONTRIBUTORS Caelum: Rafael Kitover frew: Arthur Axel "fREW" Schmidt groditi: Guillermo Roditi Jason Plum ribasushi: Peter Rabbitson COPYRIGHT & LICENSE Copyright (c) 2006-2010 Matt S. Trout This program is free software; you can redistribute it and/or modify it under the same terms as perl itself.