File Coverage

blib/lib/MooX/TaggedAttributes/Role.pm
Criterion Covered Total %
statement 21 21 100.0
branch 2 2 100.0
condition 2 6 33.3
subroutine 7 7 100.0
pod n/a
total 32 36 88.8


line stmt bran cond sub pod time code
1              
2             # ABSTRACT: "Parent" Tag Role
3              
4             ## no critic
5             our $VERSION = '0.18';
6             ## use critic
7              
8             use MRO::Compat;
9 5     5   2676  
  5         11  
  5         129  
10             use Scalar::Util ();
11 5     5   23 use MooX::TaggedAttributes ();
  5         12  
  5         62  
12 5     5   22 use Sub::Name ();
  5         9  
  5         69  
13 5     5   22  
  5         9  
  5         87  
14             # Moo::Role won't compose anything before it was used into a consuming
15             # package.
16             use Moo::Role;
17 5     5   21  
  5         16  
  5         29  
18             # sub import;
19             # *import = \&MooX::TaggedAttributes::import;
20              
21             my $maybe_next_method = sub { ( shift )->maybe::next::method };
22              
23             # this modifier is run once for each composition of a tag role into
24             # the class. role composition is orthogonal to class inheritance, so we
25             # need to carefully handle both
26              
27             # see http://www.nntp.perl.org/group/perl.moose/2015/01/msg287{6,7,8}.html,
28             # but note that djerius' published solution was incomplete.
29             around _tag_list => sub {
30              
31             # 1. call &$orig to handle tag role compositions into the current class
32             # 2. call up the inheritance stack to handle parent class tag role compositions.
33              
34             my $orig = shift;
35             my $package = caller;
36              
37             # create the proper environment context for next::can
38             my $code
39             = Sub::Name::subname( "${package}::_tag_list" => $maybe_next_method );
40             my $next = $_[0]->$code;
41              
42             # say STDERR "$package => $code";;
43              
44             return [ @{&$orig}, $next ? @{$next} : () ];
45             };
46              
47              
48             # _tags can't be lazy; we must resolve the tags and attributes at
49             # object creation time in case a role is modified after this object
50             # is created, as we scan both clsses and roles to gather the tags.
51             # classes should be immutable after the first instantiation
52             # of an object (but see RT#101631), but roles aren't.
53              
54             # We also need to identify when a role has been added to an *object*
55             # which adds tagged attributes. TODO: make this work.
56              
57             # this is where all of the tags get stored while a class is being
58             # built up. eventually they are condensed into a simple hash via
59             # _build_cache
60              
61              
62 92     92   373  
63              
64              
65              
66              
67              
68              
69              
70              
71              
72              
73              
74              
75             my $class = Scalar::Util::blessed $_[0];
76              
77             # called as an object method?
78 68     68   282081 if ( defined $class ) {
79             return $MooX::TaggedAttributes::TAGCACHE{$class}
80             //= MooX::TaggedAttributes::Cache->new( $class );
81 68 100       194 }
82 16   33     96  
83             else {
84             $class = $_[0];
85             return $MooX::TaggedAttributes::TAGCACHE{$class}
86             // MooX::TaggedAttributes::Cache->new( $class );
87 52         103 }
88 52   33     391  
89             }
90              
91             1;
92              
93              
94             =pod
95              
96             =for :stopwords Diab Jerius Smithsonian Astrophysical Observatory
97              
98             =head1 NAME
99              
100             MooX::TaggedAttributes::Role - "Parent" Tag Role
101              
102             =head1 VERSION
103              
104             version 0.18
105              
106             =head1 SUBROUTINES
107              
108             =head2 _tags
109              
110             $tag_object = $class->_tags;
111             $tag_object = object->_tags;
112              
113             Return the tags.
114              
115             If this is the first time this has been called as an object method,
116             the tag object will be cached for future use, otherwise it is newly
117             constructed from L</tag_list()>.
118              
119             =head1 SUPPORT
120              
121             =head2 Bugs
122              
123             Please report any bugs or feature requests to bug-moox-taggedattributes@rt.cpan.org or through the web interface at: https://rt.cpan.org/Public/Dist/Display.html?Name=MooX-TaggedAttributes
124              
125             =head2 Source
126              
127             Source is available at
128              
129             https://gitlab.com/djerius/moox-taggedattributes
130              
131             and may be cloned from
132              
133             https://gitlab.com/djerius/moox-taggedattributes.git
134              
135             =head1 SEE ALSO
136              
137             Please see those modules/websites for more information related to this module.
138              
139             =over 4
140              
141             =item *
142              
143             L<MooX::TaggedAttributes|MooX::TaggedAttributes>
144              
145             =back
146              
147             =head1 AUTHOR
148              
149             Diab Jerius <djerius@cpan.org>
150              
151             =head1 COPYRIGHT AND LICENSE
152              
153             This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
154              
155             This is free software, licensed under:
156              
157             The GNU General Public License, Version 3, June 2007
158              
159             =cut