1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
#!/usr/bin/perl
use v5.14;
use warnings;
use Test2::V0;
use Attribute::Storage qw( find_subs_with_attr );
{
package Testing;
use Attribute::Storage;
sub Title :ATTR(CODE)
{
my $package = shift;
my ( $title ) = @_;
return $title;
}
sub one :Title("One") { 1 }
sub two :Title("Two") { 2 }
sub three :Title("Three") { 3 }
package SubClass;
use base qw( Testing );
sub four :Title("Four") {}
}
my %subs = find_subs_with_attr "Testing", "Title";
is( $subs{one}, \&Testing::one, 'find_subs_with_attr finds sub one()' );
is( $subs{two}, \&Testing::two, 'find_subs_with_attr finds sub two()' );
is( $subs{three}, \&Testing::three, 'find_subs_with_attr finds sub three()' );
%subs = find_subs_with_attr( [qw( SubClass Testing )], "Title" );
is( $subs{one}, \&Testing::one, 'find_subs_with_attr on subclass finds parent subs' );
# matching
{
my %subs = find_subs_with_attr "Testing", "Title", matching => sub { length == 3 };
ok( defined $subs{one}, 'find_subs_with_attr matching CODE finds one' );
ok( !defined $subs{three}, 'find_subs_with_attr matching CODE does not find three' );
%subs = find_subs_with_attr "Testing", "Title", matching => qr/^...$/;
ok( defined $subs{one}, 'find_subs_with_attr matching Regexp finds one' );
ok( !defined $subs{three}, 'find_subs_with_attr matching Regexp does not find three' );
}
# filter
{
my %subs = find_subs_with_attr "Testing", "Title", filter => sub {
my ( $cv ) = @_;
return $cv->() % 2;
};
ok( defined $subs{one}, 'find_subs_with_attr filter finds one' );
ok( !defined $subs{two}, 'find_subs_with_attr filter does not find two' );
}
done_testing;
|
