File Coverage

blib/lib/Variable/Declaration.pm
Criterion Covered Total %
statement 122 122 100.0
branch 40 42 95.2
condition 14 14 100.0
subroutine 29 29 100.0
pod 0 8 0.0
total 205 215 95.3


line stmt bran cond sub pod time code
1             package Variable::Declaration;
2 14     14   966624 use v5.12.0;
  14         191  
3 14     14   84 use strict;
  14         38  
  14         304  
4 14     14   75 use warnings;
  14         28  
  14         611  
5              
6             our $VERSION = "0.05";
7              
8 14     14   7008 use Keyword::Simple;
  14         353749  
  14         609  
9 14     14   14195 use PPR;
  14         603517  
  14         564  
10 14     14   150 use Carp ();
  14         31  
  14         273  
11 14     14   8002 use Import::Into;
  14         37371  
  14         434  
12 14     14   6195 use Data::Lock ();
  14         88605  
  14         381  
13 14     14   6888 use Type::Tie ();
  14         163262  
  14         22912  
14              
15             our $LEVEL;
16             our $DEFAULT_LEVEL = 2;
17              
18             sub import {
19 21     21   13257 shift;
20 21         69 my %args = @_;
21 21         56 my $caller = caller;
22              
23             $LEVEL = exists $args{level} ? $args{level}
24 21 100       121 : exists $ENV{'Variable::Declaration::LEVEL'} ? $ENV{'Variable::Declaration::LEVEL'}
    100          
25             : $DEFAULT_LEVEL;
26              
27 21         212 feature->import::into($caller, 'state');
28              
29 21         6976 Keyword::Simple::define 'let' => \&define_let;
30 21         673 Keyword::Simple::define 'static' => \&define_static;
31 21         438 Keyword::Simple::define 'const' => \&define_const;
32             }
33              
34             sub unimport {
35 1     1   22 Keyword::Simple::undefine 'let';
36 1         40 Keyword::Simple::undefine 'static';
37 1         19 Keyword::Simple::undefine 'const';
38             }
39              
40 32     32 0 62476 sub define_let { define_declaration(let => 'my', @_) }
41 12     12 0 39509 sub define_static { define_declaration(static => 'state', @_) }
42 14     14 0 31463 sub define_const { define_declaration(const => 'my', @_) }
43              
44             sub define_declaration {
45 58     58 0 250 my ($declaration, $perl_declaration, $ref) = @_;
46              
47 58         283 my $match = _valid($declaration => _parse($$ref));
48 38         267 my $tv = _parse_type_varlist($match->{type_varlist});
49 38         1786 my $args = +{ declaration => $declaration, perl_declaration => $perl_declaration, %$match, %$tv, level => $LEVEL };
50              
51 38         413 substr($$ref, 0, length $match->{statement}) = _render_declaration($args);
52             }
53              
54 23     23 0 5413 sub croak { Carp::croak @_ }
55              
56 2     2 0 113 sub data_lock { Data::Lock::dlock @_ }
57              
58             sub type_tie(\[$@%]@);
59             {
60             *type_tie = \&Type::Tie::ttie;
61             }
62              
63             our %metadata;
64             sub info {
65 5     5 0 474 my $variable_ref = shift;
66 5 50       18 die 'argument must be reference' unless ref $variable_ref;
67 5 50       19 my $info = $metadata{$variable_ref} or return undef;
68 5         503 require Variable::Declaration::Info;
69             Variable::Declaration::Info->new(
70             declaration => $info->{declaration},
71             type => $info->{type},
72             attributes => $info->{attributes},
73             )
74 5         29 }
75              
76             sub register_info {
77 17     17 0 16453 my ($variable_ref, $info) = @_;
78             $metadata{$variable_ref} = {
79             declaration => $info->{declaration},
80             type => $info->{type},
81             attributes => $info->{attributes},
82 17         110 };
83             }
84              
85             sub _valid {
86 58     58   396 my ($declaration, $match) = @_;
87              
88             croak "variable declaration is required"
89 58 100       347 unless $match->{type_varlist};
90              
91 49         229 my ($eq, $assign) = ($match->{eq}, $match->{assign});
92 49 100       263 if ($declaration eq 'const') {
93 11 100 100     98 croak "'const' declaration must be assigned"
94             unless defined $eq && defined $assign;
95             }
96             else {
97 38 100 100     370 croak "illegal expression"
      100        
      100        
98             unless (defined $eq && defined $assign) or (!defined $eq && !defined $assign);
99             }
100              
101 38         115 return $match;
102             }
103              
104             sub _render_declaration {
105 38     38   242 my $args = shift;
106 38         125 my @lines;
107 38         219 push @lines => _lines_declaration($args);
108 38         204 push @lines => _lines_register_info($args);
109 38 100       255 push @lines => _lines_type_check($args) if $args->{level} >= 1;
110 38 100       212 push @lines => _lines_type_tie($args) if $args->{level} == 2;
111 38 100       194 push @lines => _lines_data_lock($args) if $args->{declaration} eq 'const';
112 38         12673 return join ";", @lines;
113             }
114              
115             sub _lines_declaration {
116 38     38   91 my $args = shift;
117 38         143 my $s = $args->{perl_declaration};
118 38         99 $s .= do {
119 38         110 my $s = join ', ', map { $_->{var} } @{$args->{type_vars}};
  38         237  
  38         181  
120 38 100       231 $args->{is_list_context} ? " ($s)" : " $s";
121             };
122 38 100       170 $s .= $args->{attributes} if $args->{attributes};
123 38 100       189 $s .= " = @{[$args->{assign}]}" if defined $args->{assign};
  24         115  
124 38         179 return ($s);
125             }
126              
127             sub _lines_type_tie {
128 31     31   81 my $args = shift;
129 31         69 my @lines;
130 31         52 for (@{$args->{type_vars}}) {
  31         104  
131 31         91 my ($type, $var) = ($_->{type}, $_->{var});
132 31 100       87 next unless $type;
133 7         36 push @lines => sprintf('Variable::Declaration::type_tie(%s, %s, %s)', $var, $type, $var);
134             }
135 31         69 return @lines;
136             }
137              
138             sub _lines_type_check {
139 35     35   71 my $args = shift;
140 35         81 my @lines;
141 35         66 for (@{$args->{type_vars}}) {
  35         138  
142 35         164 my ($type, $var) = ($_->{type}, $_->{var});
143 35 100       117 next unless $type;
144 11         54 push @lines => sprintf('Variable::Declaration::croak(%s->get_message(%s)) unless %s->check(%s)', $type, $var, $type, $var)
145             }
146 35         105 return @lines;
147             }
148              
149             sub _lines_data_lock {
150 4     4   12 my $args = shift;
151 4         12 my @lines;
152 4         11 for my $type_var (@{$args->{type_vars}}) {
  4         15  
153 4         22 push @lines => "Variable::Declaration::data_lock($type_var->{var})";
154             }
155 4         12 return @lines;
156             }
157              
158             sub _lines_register_info {
159 38     38   108 my $args = shift;
160 38         72 my @lines;
161 38         103 for my $type_var (@{$args->{type_vars}}) {
  38         192  
162             push @lines => sprintf("Variable::Declaration::register_info(\\%s, { declaration => '%s', attributes => %s, type => %s })",
163             $type_var->{var},
164             $args->{declaration},
165             ($args->{attributes} ? "'$args->{attributes}'" : 'undef'),
166 38 100 100     558 ($type_var->{type} or 'undef'),
167             );
168             }
169 38         122 return @lines;
170             }
171              
172             sub _parse {
173 92     92   169995 my $src = shift;
174              
175 92 100       3059116 return unless $src =~ m{
176             \A
177             (?
178             (?&PerlOWS)
179             (?
180             (?
181             (?&PerlIdentifier)? (?&PerlOWS)
182             (?&PerlVariable)
183             | (?&PerlParenthesesList)
184             ) (?&PerlOWS)
185             (?(?&PerlAttributes))? (?&PerlOWS)
186             )
187             (?=)? (?&PerlOWS)
188             (?(?&PerlConditionalExpression))?
189             ) $PPR::GRAMMAR }x;
190              
191             return +{
192             statement => $+{statement},
193             type_varlist => $+{type_varlist},
194             assign_to => $+{assign_to},
195             eq => $+{eq},
196             assign => $+{assign},
197             attributes => $+{attributes},
198             }
199 83         19805 }
200              
201             sub _parse_type_varlist {
202 50     50   53966 my $expression = shift;
203              
204 50 100       1565607 if ($expression =~ m{ (?(?&PerlParenthesesList)) $PPR::GRAMMAR }x) {
    100          
205 9         224 my ($type_vars) = $+{list} =~ m/\A\((.+)\)\Z/;
206 9         87 my @list = split ',', $type_vars;
207             return +{
208             is_list_context => 1,
209 9         43 type_vars => [ map { _parse_type_var($_) } @list ],
  12         62  
210             }
211             }
212             elsif (my $type_var = _parse_type_var($expression)) {
213             return +{
214 39         7863 is_list_context => 0,
215             type_vars => [ $type_var ],
216             }
217             }
218             else {
219 2         356 return;
220             }
221             }
222              
223             sub _parse_type_var {
224 92     92   53155 my $expression = shift;
225              
226 92 100       3018396 return unless $expression =~ m{
227             \A
228             (?&PerlOWS)
229             (?(?&PerlIdentifier) | (?&PerlCall) )? (?&PerlOWS)
230             (?(?:(?&PerlVariable)))
231             (?&PerlOWS)
232             \Z
233             $PPR::GRAMMAR
234             }x;
235              
236             return +{
237             type => $+{type},
238             var => $+{var},
239             }
240 83         17822 }
241              
242             1;
243             __END__