File Coverage

blib/lib/Marpa/R3/Glade.pm
Criterion Covered Total %
statement 62 122 50.8
branch 6 30 20.0
condition 2 14 14.2
subroutine 12 16 75.0
pod 0 5 0.0
total 82 187 43.8


line stmt bran cond sub pod time code
1             # Marpa::R3 is Copyright (C) 2018, Jeffrey Kegler.
2             #
3             # This module is free software; you can redistribute it and/or modify it
4             # under the same terms as Perl 5.10.1. For more details, see the full text
5             # of the licenses in the directory LICENSES.
6             #
7             # This program is distributed in the hope that it will be
8             # useful, but it is provided "as is" and without any express
9             # or implied warranties. For details, see the full text of
10             # of the licenses in the directory LICENSES.
11              
12             package Marpa::R3::Glade;
13              
14 104     104   2144 use 5.010001;
  104         345  
15 104     104   530 use strict;
  104         200  
  104         2273  
16 104     104   701 use warnings;
  104         212  
  104         3308  
17 104     104   524 no warnings qw(recursion);
  104         202  
  104         4033  
18              
19 104     104   621 use vars qw($VERSION $STRING_VERSION);
  104         206  
  104         8375  
20             $VERSION = '4.001_054';
21             $STRING_VERSION = $VERSION;
22             ## no critic(BuiltinFunctions::ProhibitStringyEval)
23             $VERSION = eval $VERSION;
24             ## use critic
25              
26             # The code in this file, for now, breaks "the rules". It makes use
27             # of internal methods not documented as part of Libmarpa.
28             # It is intended to create documented Libmarpa methods to underlie
29             # this interface, and rewrite it to use them
30              
31             package Marpa::R3::Internal_Glade;
32              
33 104     104   644 use Scalar::Util qw(blessed tainted);
  104         205  
  104         6046  
34 104     104   608 use English qw( -no_match_vars );
  104         256  
  104         614  
35              
36             our $PACKAGE = 'Marpa::R3::Glade';
37              
38             # Set those common args which are at the Perl level.
39             # This is more complicated that it needs to be for the current implementation.
40             # It allows for LHS terminals (implemented in Libmarpa but not allowed by the SLIF).
41             # It also assumes that every or-node which can be constructed from preceding or-nodes
42             # and the input will be present. This is currently the case, but in the future
43             # rules and/or symbols may have extra-syntactic conditions attached making this
44             # assumption false.
45              
46             # Set those common args which are at the Perl level.
47             sub glade_common_set {
48 1     1   2 my ( $glade, $flat_args ) = @_;
49 1 50       4 if ( my $value = $flat_args->{'trace_file_handle'} ) {
50 0         0 $glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE] = $value;
51             }
52 1         6 my $trace_file_handle =
53             $glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE];
54 1         2 delete $flat_args->{'trace_file_handle'};
55 1         2 return $flat_args;
56             }
57              
58             sub Marpa::R3::Internal_Glade::peak {
59 1     1   3 my ( $asf, @args ) = @_;
60 1         5 my $glade = bless [], "Marpa::R3::Glade";
61              
62 1         2 my $end_of_parse;
63              
64 1         3 my ( $flat_args, $error_message ) = Marpa::R3::flatten_hash_args( \@args );
65 1 50       3 Marpa::R3::exception( sprintf $error_message, '$glade->peak' )
66             if not $flat_args;
67 1         4 $flat_args = glade_common_set( $glade, $flat_args );
68              
69 1         3 my $asf_class = 'Marpa::R3::ASF';
70 1 50 33     12 if ( not blessed $asf or not $asf->isa($asf_class) ) {
71 0         0 my $ref_type = ref $asf;
72 0 0       0 my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref';
73 0         0 Marpa::R3::exception(
74             qq{'recognizer' named argument to new() is $desc\n},
75             " It should be a ref to $asf_class\n"
76             );
77             }
78              
79 1   33     7 $glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE] //=
80             $asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE];
81              
82 1         1 my $trace_file_handle =
83             $glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE];
84              
85 1         2 my $lua = $asf->[Marpa::R3::Internal_ASF::L];
86 1         3 $glade->[Marpa::R3::Internal_Glade::L] = $lua;
87              
88             my ( $regix ) = $asf->coro_by_tag(
89             ( '@' . __FILE__ . ':' . __LINE__ ),
90             {
91             signature => 's',
92             args => [$flat_args],
93             handlers => {
94             trace => sub {
95 0     0   0 my ($msg) = @_;
96 0         0 say {$trace_file_handle} $msg;
  0         0  
97 0         0 return 'ok';
98             },
99             }
100             },
101 1         11 <<'END_OF_LUA');
102             local asf, flat_args = ...
103             _M.wrap(function ()
104             local peak = asf:peak(flat_args)
105             if not peak then return 'ok', -1 end
106             return 'ok', peak.regix
107             end)
108             END_OF_LUA
109              
110 1 50       7 return if $regix < 0;
111 1         2 $glade->[Marpa::R3::Internal_Glade::REGIX] = $regix;
112 1         4 return $glade;
113              
114             }
115              
116             sub Marpa::R3::Glade::DESTROY {
117             # say STDERR "In Marpa::R3::Glade::DESTROY before test";
118 1     1   883 my $glade = shift;
119 1         2 my $lua = $glade->[Marpa::R3::Internal_Glade::L];
120              
121             # If we are destroying the Perl interpreter, then all the Marpa
122             # objects will be destroyed, including Marpa's Lua interpreter.
123             # We do not need to worry about cleaning up the
124             # recognizer is an orderly manner, because the Lua interpreter
125             # containing the recognizer will be destroyed.
126             # In fact, the Lua interpreter may already have been destroyed,
127             # so this test is necessary to avoid a warning message.
128 1 50       4 return if not $lua;
129             # say STDERR "In Marpa::R3::Glade::DESTROY after test";
130              
131 1         2 my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX];
132 1         3 $glade->call_by_tag(
133             ('@' . __FILE__ . ':' . __LINE__),
134             <<'END_OF_LUA', '');
135             local glade = ...
136             local regix = glade.regix
137             _M.unregister(_M.registry, regix)
138             END_OF_LUA
139             }
140              
141             # not to be documented
142             sub Marpa::R3::Glade::call_by_tag {
143 2     2 0 5 my ( $glade, $tag, $codestr, $signature, @args ) = @_;
144 2         3 my $lua = $glade->[Marpa::R3::Internal_Glade::L];
145 2         3 my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX];
146              
147 2         5 my @results;
148             my $eval_error;
149 2         0 my $eval_ok;
150             {
151 2         3 local $@;
  2         2  
152 2         4 $eval_ok = eval {
153 2         44 @results =
154             $lua->call_by_tag( $regix, $tag, $codestr, $signature, @args );
155 2         4 return 1;
156             };
157 2         6 $eval_error = $@;
158             }
159 2 50       6 if ( not $eval_ok ) {
160 0         0 Marpa::R3::exception($eval_error);
161             }
162 2         8 return @results;
163             }
164              
165             # not to be documented
166             sub Marpa::R3::Glade::coro_by_tag {
167 0     0 0 0 my ( $glade, $tag, $args, $codestr ) = @_;
168 0         0 my $lua = $glade->[Marpa::R3::Internal_ASF::L];
169 0         0 my $regix = $glade->[Marpa::R3::Internal_ASF::REGIX];
170 0   0     0 my $handler = $args->{handlers} // {};
171 0         0 my $resume_tag = $tag . '[R]';
172 0   0     0 my $signature = $args->{signature} // '';
173 0   0     0 my $p_args = $args->{args} // [];
174              
175 0         0 my @results;
176             my $eval_error;
177 0         0 my $eval_ok;
178             {
179 0         0 local $@;
  0         0  
180 0         0 $eval_ok = eval {
181 0         0 $lua->call_by_tag( $regix, $tag, $codestr, $signature, @{$p_args} );
  0         0  
182 0         0 my @resume_args = ('');
183 0         0 my $signature = 's';
184 0         0 CORO_CALL: while (1) {
185 0         0 my ( $cmd, $yield_data ) =
186             $lua->call_by_tag( $regix, $resume_tag,
187             'local glade, resume_arg = ...; return _M.resume(resume_arg)',
188             $signature, @resume_args ) ;
189 0 0       0 if (not $cmd) {
190 0         0 @results = @{$yield_data};
  0         0  
191 0         0 return 1;
192             }
193 0         0 my $handler = $handler->{$cmd};
194 0 0       0 Marpa::R3::exception(qq{No coro handler for "$cmd"})
195             if not $handler;
196 0   0     0 $yield_data //= [];
197 0         0 my ($handler_cmd, $new_resume_args) = $handler->(@{$yield_data});
  0         0  
198 0 0       0 Marpa::R3::exception(qq{Undefined return command from handler for "$cmd"})
199             if not defined $handler_cmd;
200 0 0       0 if ($handler_cmd eq 'ok') {
201 0         0 $signature = 's';
202 0         0 @resume_args = ($new_resume_args);
203 0 0       0 if (scalar @resume_args < 1) {
204 0         0 @resume_args = ('');
205             }
206 0         0 next CORO_CALL;
207             }
208 0 0       0 if ($handler_cmd eq 'sig') {
209 0         0 @resume_args = @{$new_resume_args};
  0         0  
210 0         0 $signature = shift @resume_args;
211 0         0 next CORO_CALL;
212             }
213 0         0 Marpa::R3::exception(qq{Bad return command ("$handler_cmd") from handler for "$cmd"})
214             }
215 0         0 return 1;
216             };
217 0         0 $eval_error = $@;
218             }
219 0 0       0 if ( not $eval_ok ) {
220             # if it's an object, just die
221 0 0       0 die $eval_error if ref $eval_error;
222 0         0 Marpa::R3::exception($eval_error);
223             }
224 0         0 return @results;
225             }
226              
227             sub Marpa::R3::Glade::g1_span {
228 1     1 0 5 my ($glade) = @_;
229              
230 1         5 my ($g1_start, $g1_length) = $glade->call_by_tag(
231             ('@' . __FILE__ . ':' . __LINE__),
232             <<'END__OF_LUA', '>*' );
233             local glade = ...
234             return glade:g1_span()
235             END__OF_LUA
236 1         3 return $g1_start, $g1_length;
237             }
238              
239             sub Marpa::R3::Glade::dump {
240 0     0 0   my ($glade) = @_;
241 0           return "";
242             }
243              
244             # not to be documented
245             sub Marpa::R3::Glade::regix {
246 0     0 0   my ( $glade ) = @_;
247 0           my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX];
248 0           return $regix;
249             }
250              
251             1;
252              
253             # vim: expandtab shiftwidth=4: