File Coverage

blib/lib/mop/internals/syntax.pm
Criterion Covered Total %
statement 42 47 89.3
branch 11 12 91.6
condition n/a
subroutine 11 12 91.6
pod 0 8 0.0
total 64 79 81.0


line stmt bran cond sub pod time code
1             package mop::internals::syntax;
2              
3 143     143   1643 use v5.16;
  143         474  
  143         5390  
4 143     143   797 use warnings;
  143         256  
  143         3695  
5              
6 143     143   128066 use version ();
  143         389930  
  143         3720  
7 143     143   155930 use Devel::CallParser ();
  143         678094  
  143         161280  
8              
9             our $VERSION = '0.03';
10             our $AUTHORITY = 'cpan:STEVAN';
11              
12             my @available_keywords = qw(class role method has);
13              
14             # keep the local metaclass around
15             our $CURRENT_META;
16              
17             sub setup_for {
18 168     168 0 413 my ($pkg) = @_;
19              
20 168         1138 $^H{__PACKAGE__ . '/twigils'} = 1;
21             mop::internals::util::install_sub($pkg, 'mop::internals::syntax', $_)
22 168         1672 for @available_keywords;
23             }
24              
25             sub teardown_for {
26 6     6 0 8 my ($pkg) = @_;
27              
28             mop::internals::util::uninstall_sub($pkg, $_)
29 6         35 for @available_keywords;
30             }
31              
32             sub new_meta {
33 442     442 0 62577 my ($metaclass, $name, $version, $roles, $superclass) = @_;
34              
35 89 50       275 $metaclass->new(
36             name => $name,
37             version => $version,
38             roles => [map {
39 442         3618 mop::meta($_) or die "Could not find metaclass for role: $_"
40 442 100       1296 } @{ $roles }],
41             (defined $superclass
42             ? (superclass => $superclass)
43             : ()),
44             );
45             }
46              
47             sub build_meta {
48 422     422 0 1136 my ($meta, $body, @traits) = @_;
49              
50 422         1402 while (@traits) {
51 37         111 my ($trait, $args) = splice @traits, 0, 2;
52 37 100       220 mop::traits::util::apply_trait(
53             $trait, $meta, $args ? @$args : (),
54             );
55             }
56              
57 419         2113 $meta->FINALIZE;
58              
59 408         1702 $body->();
60             }
61              
62             sub add_method {
63 438     438 0 2888 my ($name, $body, @traits) = @_;
64              
65 438 100       1051 if ($body) {
66 416         1650 $CURRENT_META->add_method(
67             $CURRENT_META->method_class->new(
68             name => $name,
69             body => mop::internals::util::subname(
70             (join '::' => $CURRENT_META->name, $name),
71             $body,
72             ),
73             )
74             );
75              
76 416         1951 while (@traits) {
77 23         82 my ($trait, $args) = splice @traits, 0, 2;
78 23 100       88 mop::traits::util::apply_trait(
79             $trait, $CURRENT_META->get_method($name), $args ? @$args : (),
80             );
81             }
82             }
83             else {
84 22         73 $CURRENT_META->add_required_method($name);
85             }
86              
87 438         11710 return;
88             }
89              
90             sub add_attribute {
91 195     195 0 1100 my ($name, $default, @traits) = @_;
92              
93 195         875 $CURRENT_META->add_attribute(
94             $CURRENT_META->attribute_class->new(
95             name => $name,
96             default => $default,
97             )
98             );
99              
100 195         840 while (@traits) {
101 102         262 my ($trait, $args) = splice @traits, 0, 2;
102 102 100       948 mop::traits::util::apply_trait(
103             $trait, $CURRENT_META->get_attribute($name), $args ? @$args : (),
104             );
105             }
106              
107 194         7821 return;
108             }
109              
110             # B::Deparse doesn't know what to do with custom ops
111             {
112             package
113             B::Deparse;
114             sub pp_init_attr {
115             # XXX not sure why this doesn't work
116             # "(init_attr " . maybe_targmy(@_, \&listop) . ")";
117 0     0 0 0 my $self = shift;
118 0         0 my ($op) = @_;
119 0         0 my $targ = $self->padname($op->targ);
120 0         0 return "(init_attr " . $targ . ": "
121 0         0 . join(', ', map { $self->deparse($_) }
122             $op->first,
123             $op->first->sibling,
124             $op->first->sibling->sibling)
125             . ")";
126             }
127 2     2 0 2189 sub pp_intro_invocant { "(intro invocant)" }
128             }
129              
130             1;
131              
132             __END__