File Coverage

blib/lib/Moops/Parser.pm
Criterion Covered Total %
statement 168 169 99.4
branch 51 60 85.0
condition 14 15 93.3
subroutine 28 28 100.0
pod 0 4 0.0
total 261 276 94.5


line stmt bran cond sub pod time code
1 36     36   434 use v5.14;
  36         134  
2 36     36   186 use strict;
  36         61  
  36         1098  
3 36     36   171 use warnings FATAL => 'all';
  36         70  
  36         1483  
4 36     36   186 no warnings qw(void once uninitialized numeric);
  36         62  
  36         2536  
5              
6             package Moops::Parser;
7              
8             our $AUTHORITY = 'cpan:TOBYINK';
9             our $VERSION = '0.037';
10              
11 2     2   946 use Moo;
  2     35   14044  
  2         9  
  35         16979  
  35         353049  
  35         233  
12 2     2   2626 use Keyword::Simple ();
  2     34   3  
  2         41  
  35         90787  
  35         87  
  35         983  
13 2     2   8 use Module::Runtime qw($module_name_rx);
  2     34   4  
  2         19  
  34         197  
  34         85  
  34         533  
14 2     2   863 use namespace::autoclean;
  2     34   27018  
  2         8  
  34         15126  
  34         385601  
  34         169  
15              
16             # I'm just going to assume that 0.01 is the only version that is ever going
17             # to have that problem...
18 2 50   2   869 use PerlX::Define _RT88970 => (Keyword::Simple->VERSION == 0.01) ? 1 : 0;
  2 50   34   1261  
  2         37  
  34         16808  
  34         24516  
  34         756  
19              
20             has 'keyword' => (is => 'ro');
21             has 'ccstash' => (is => 'ro');
22             has 'ref' => (is => 'ro');
23              
24             # Not set in constructor; set by parse method.
25             has 'package' => (is => 'rwp', init_arg => undef);
26             has 'version' => (is => 'rwp', init_arg => undef, predicate => 'has_version');
27             has 'relations' => (is => 'rwp', init_arg => undef, default => sub { +{} });
28             has 'version_checks' => (is => 'rwp', init_arg => undef, default => sub { [] });
29             has 'traits' => (is => 'rwp', init_arg => undef, default => sub { +{} });
30             has 'is_empty' => (is => 'rwp', init_arg => undef, default => sub { 0 });
31             has 'done' => (is => 'rwp', init_arg => undef, default => sub { 0 });
32              
33             has 'lines' => (is => 'rw', init_arg => undef, default => sub { 0 });
34              
35             has 'class_for_keyword' => (
36             is => 'lazy',
37             builder => 1,
38             handles => {
39             known_relationships => 'known_relationships',
40             qualify_relationship => 'qualify_relationship',
41             version_relationship => 'version_relationship',
42             },
43             );
44              
45             sub _eat
46             {
47 639     639   979 my $self = shift;
48 639         1253 my ($bite) = @_;
49 639         963 my $ref = $self->{ref};
50            
51 639 100 66     7453 if (ref($bite) and $$ref =~ /\A($bite)/sm)
    50          
52             {
53 240         834 my $r = $1;
54 240         570 substr($$ref, 0, length($r)) = '';
55 240         831 return $r;
56             }
57             elsif (!ref($bite))
58             {
59 399 100       1377 substr($$ref, 0, length($bite)) eq $bite
60             or Carp::croak("Expected $bite; got $$ref");
61 398         1191 substr($$ref, 0, length($bite)) = '';
62 398         695 return $bite;
63             }
64            
65 0         0 Carp::croak("Expected $bite; got $$ref");
66             }
67              
68             sub _eat_space
69             {
70 566     566   850 my $self = shift;
71 566         867 my $ref = $self->{ref};
72            
73 566         767 my $X;
74 566   100     3371 while (
      100        
      100        
75             ($$ref =~ m{\A( \s+ )}x and $X = 1)
76             or ($$ref =~ m{\A\#} and $X = 2)
77             ) {
78 319 100       1137 $X==2
79             ? $self->_eat(qr{\A\#.+?\n}sm)
80             : $self->_eat($1);
81 319 100       2848 $self->{lines} += $X==2
82             ? 1
83             : (my @tmp = split /\n/, $1, -1)-1;
84             }
85 566         1339 return;
86             }
87              
88             sub _peek
89             {
90 570     570   917 my $self = shift;
91 570         790 my $re = $_[0];
92 570         900 my $ref = $self->{ref};
93            
94 570         11860 return scalar($$ref =~ m{\A$re});
95             }
96              
97             sub _eat_package
98             {
99 125     125   239 my $self = shift;
100 125         250 my ($rel) = @_;
101 125         1910 my $pkg = $self->_eat(qr{(?:::)?$module_name_rx});
102 125         589 return $self->qualify_module_name($pkg, $rel);
103             }
104              
105             sub _eat_package_and_version
106             {
107 34     34   70 my $self = shift;
108 34         79 my ($rel) = @_;
109            
110 34         535 my $pkg = $self->_eat(qr{(?:::)?$module_name_rx});
111 34         159 $self->_eat_space;
112            
113 34 100       117 my $ver = $self->_peek_version ? $self->_eat_version : undef;
114            
115             return (
116 34         144 $self->qualify_module_name($pkg, $rel),
117             $ver,
118             );
119             }
120              
121             {
122             my $v_re = qr{v?[0-9._]+};
123 129     129   409 sub _peek_version { shift->_peek($v_re) }
124 7     7   23 sub _eat_version { shift->_eat($v_re) }
125             }
126              
127             sub _eat_relations
128             {
129 95     95   216 my $self = shift;
130            
131 95         1531 my $RELS = join '|', map quotemeta, $self->known_relationships;
132 95         2275 $RELS = qr/\A($RELS)/sm;
133            
134 95         288 my (%relationships, @vchecks);
135 95         320 while ($self->_peek($RELS))
136             {
137 61         279 my $rel = $self->_eat($RELS);
138 61         257 $self->_eat_space;
139            
140 61         1362 my $with_version = $self->version_relationship($rel);
141            
142 61 100       284 my ($pkg, $ver) = $with_version ? $self->_eat_package_and_version($rel) : $self->_eat_package($rel);
143 61         192 my @modules = $pkg;
144 61 100       182 push @vchecks, [$pkg, $ver] if $ver;
145 61         182 $self->_eat_space;
146 61         306 while ($self->_peek(qr/\A,/))
147             {
148 3         16 $self->_eat(',');
149 3         14 $self->_eat_space;
150 3 50       18 my ($pkg, $ver) = $with_version ? $self->_eat_package_and_version($rel) : $self->_eat_package($rel);
151 3         13 push @modules, $pkg;
152 3 50       16 push @vchecks, [$pkg, $ver] if $ver;
153 3         11 $self->_eat_space;
154             }
155            
156 61   100     167 push @{ $relationships{$rel}||=[] }, @modules;
  61         518  
157             }
158            
159 95 50       737 wantarray ? (\%relationships, \@vchecks) : \%relationships;
160             }
161              
162             sub _eat_traits
163             {
164 7     7   14 my $self = shift;
165            
166 7         15 my %traits;
167 7         32 while ($self->_peek(qr/[A-Za-z]\w+/))
168             {
169 8         50 my $trait = $self->_eat(qr/[A-Za-z]\w+/);
170 8         57 $self->_eat_space;
171            
172 8 100       53 if ($self->_peek(qr/\(/))
173             {
174 1         10 require Text::Balanced;
175 1         3 my $code = Text::Balanced::extract_codeblock(${$self->ref}, '()');
  1         11  
176 1         602 my $ccstash = $self->ccstash;
177             # stolen from Attribute::Handlers
178 1         98 my $evaled = eval("package $ccstash; no warnings; no strict; local \$SIG{__WARN__}=sub{die}; +{ $code }");
179 1         5 $traits{$trait} = $evaled;
180 1         4 $self->_eat_space;
181             }
182             else
183             {
184 7         27 $traits{$trait} = undef;
185             }
186            
187 8 100       39 if ($self->_peek(qr/:/))
188             {
189 1         6 $self->_eat(':');
190 1         2 $self->_eat_space;
191             }
192             }
193            
194 7         47 \%traits;
195             }
196              
197             sub parse
198             {
199 95     95 0 200 my $self = shift;
200 95 50       512 return if $self->done;
201            
202 95         365 $self->_eat_space;
203            
204 95         356 $self->_set_package(
205             $self->_eat_package
206             );
207            
208 95         299 $self->_eat_space;
209            
210 95 100       367 $self->_set_version(
211             $self->_eat_version
212             ) if $self->_peek_version;
213            
214 95         405 $self->_eat_space;
215            
216 95 50       2154 if ($self->known_relationships)
217             {
218 95         360 my ($rels, $vchecks) = $self->_eat_relations;
219 95         441 $self->_set_relations( $rels );
220 95         307 $self->_set_version_checks( $vchecks );
221             }
222            
223 95         323 $self->_eat_space;
224            
225 95 100       461 if ($self->_peek(qr/:/))
226             {
227 7         35 $self->_eat(':');
228 7         21 $self->_eat_space;
229 7         30 $self->_set_traits($self->_eat_traits);
230 7         21 $self->_eat_space;
231             }
232            
233 95 100       471 $self->_peek(qr/;/) ? $self->_set_is_empty(1) : $self->_eat('{');
234            
235             # We subtract 1 to work around RT#88970 when possible.
236             # This obviously won't solve anything if lines == 0
237 94         274 substr(${$self->{ref}}, 0, 0, ("\n" x ($self->{lines} - _RT88970)));
  94         475  
238            
239             # But we can try.
240 94         181 ${$self->{ref}} =~ s/\A[\t\r\x20]*\n//ms if _RT88970 && !$self->{lines};
241            
242 94         398 $self->_set_done(1);
243             }
244              
245             sub keywords
246             {
247 40     40 0 187 qw/ class role namespace library /;
248             }
249              
250             sub qualify_module_name
251             {
252 159     159 0 307 my $self = shift;
253 159         365 my ($bareword, $rel) = @_;
254 159         714 my $caller = $self->ccstash;
255            
256 159 100       552 return $1 if $bareword =~ /^::(.+)$/;
257 153 100       854 return $bareword if $caller eq 'main';
258 23 100       73 return $bareword if $bareword =~ /::/;
259 19 100 100     225 return "$caller\::$bareword" if !defined($rel) || $self->qualify_relationship($rel);
260 4         39 return $bareword;
261             }
262              
263             sub _build_class_for_keyword
264             {
265 95     95   2615 my $self = shift;
266 95         345 my $kw = $self->keyword;
267            
268 95 100       429 if ($kw eq 'class')
    100          
    100          
269             {
270 65         15839 require Moops::Keyword::Class;
271 65         1571 return 'Moops::Keyword::Class';
272             }
273             elsif ($kw eq 'role')
274             {
275 19         2411 require Moops::Keyword::Role;
276 19         423 return 'Moops::Keyword::Role';
277             }
278             elsif ($kw eq 'library')
279             {
280 2         979 require Moops::Keyword::Library;
281 2         67 return 'Moops::Keyword::Library';
282             }
283            
284 9         1001 require Moops::Keyword;
285 9         189 return 'Moops::Keyword';
286             }
287              
288             sub keyword_object
289             {
290 94     94 0 237 my $self = shift;
291 94         203 my (%attrs) = @_;
292            
293 94         2027 my $class = $self->class_for_keyword;
294            
295 94 50       868 if (my %traits = %{$self->traits || {}})
  94 100       724  
296             {
297 7         1570 require Moo::Role;
298 7         34938 $class = 'Moo::Role'->create_class_with_roles(
299             $self->class_for_keyword,
300             map("Moops::TraitFor::Keyword::$_", keys %traits),
301             );
302            
303 7         13454 for my $trait (keys %traits)
304             {
305 8 100       38 next unless defined $traits{$trait};
306             $attrs{sprintf('%s_%s', lc($trait), $_)} = $traits{$trait}{$_}
307 1         2 for keys %{$traits{$trait}};
  1         10  
308             }
309             }
310            
311             $class->new(
312 94         2355 package => $self->package,
313             (version => $self->version) x!!($self->has_version),
314             relations => $self->relations,
315             is_empty => $self->is_empty,
316             keyword => $self->keyword,
317             ccstash => $self->ccstash,
318             version_checks => $self->version_checks,
319             %attrs,
320             );
321             }
322              
323             1;