File Coverage

blib/lib/MarpaX/Demo/JSONParser.pm
Criterion Covered Total %
statement 112 115 97.3
branch 54 64 84.3
condition n/a
subroutine 15 15 100.0
pod 1 6 16.6
total 182 200 91.0


line stmt bran cond sub pod time code
1             package MarpaX::Demo::JSONParser;
2              
3 2     2   991 use strict;
  2         9  
  2         57  
4 2     2   9 use warnings;
  2         5  
  2         66  
5              
6 2     2   12 use File::Basename; # For basename.
  2         4  
  2         274  
7 2     2   1002 use File::Slurper 'read_text';
  2         27081  
  2         118  
8              
9 2     2   890 use Marpa::R2;
  2         295549  
  2         104  
10              
11 2     2   995 use MarpaX::Demo::JSONParser::Actions;
  2         5  
  2         72  
12 2     2   1003 use MarpaX::Simple qw(gen_parser);
  2         6681  
  2         140  
13              
14 2     2   1014 use Moo;
  2         25187  
  2         11  
15              
16 2     2   4169 use Types::Standard qw/Any Str/;
  2         149209  
  2         23  
17              
18             has base_name =>
19             (
20             default => sub {return ''},
21             is => 'rw',
22             isa => Str,
23             required => 0,
24             );
25              
26             has bnf_file =>
27             (
28             default => sub {return ''},
29             is => 'rw',
30             isa => Str,
31             required => 1,
32             );
33              
34             has grammar =>
35             (
36             default => sub {return ''},
37             is => 'rw',
38             isa => Any,
39             required => 0,
40             );
41              
42             has parser =>
43             (
44             default => sub {return ''},
45             is => 'rw',
46             isa => Any,
47             required => 0,
48             );
49              
50             has scanner =>
51             (
52             default => sub {return ''},
53             is => 'rw',
54             isa => Any,
55             required => 0,
56             );
57              
58             our $VERSION = '1.08';
59              
60             # ------------------------------------------------
61              
62             sub BUILD
63             {
64 60     60 0 1579 my($self) = @_;
65 60         1160 my $bnf = read_text $self -> bnf_file;
66              
67 60         12801 $self -> base_name(basename($self -> bnf_file) );
68              
69 60 100       7204 if ($self -> base_name eq 'json.1.bnf')
    100          
    50          
70             {
71 20         405 $self-> grammar
72             (
73             Marpa::R2::Scanless::G -> new
74             ({
75             default_action => 'do_first_arg',
76             source => \$bnf,
77             })
78             )
79             }
80             elsif ($self -> base_name eq 'json.2.bnf')
81             {
82 20         791 $self-> grammar
83             (
84             Marpa::R2::Scanless::G -> new
85             ({
86             bless_package => 'MarpaX::Demo::JSONParser::Actions',
87             source => \$bnf,
88             })
89             )
90             }
91             elsif ($self -> base_name eq 'json.3.bnf')
92             {
93 20         819 $self-> parser
94             (
95             gen_parser
96             (
97             grammar => $bnf,
98             )
99             );
100             }
101             else
102             {
103 0         0 die "Unknown BNF. Use either 'json.[123].bnf'\n";
104             }
105              
106 60 100       5653448 if ($self -> base_name ne 'json.3.bnf')
107             {
108 40         1242 $self -> scanner
109             (
110             Marpa::R2::Scanless::R -> new
111             ({
112             grammar => $self -> grammar,
113             semantics_package => 'MarpaX::Demo::JSONParser::Actions',
114             })
115             );
116             }
117              
118             } # End of BUILD.
119              
120             # ------------------------------------------------
121              
122             sub decode_string
123             {
124 2     2 0 9 my ($self, $s) = @_;
125              
126 2         14 $s =~ s/\\u([0-9A-Fa-f]{4})/chr(hex($1))/eg;
  1         10  
127 2         10 $s =~ s/\\n/\n/g;
128 2         7 $s =~ s/\\r/\r/g;
129 2         6 $s =~ s/\\b/\b/g;
130 2         7 $s =~ s/\\f/\f/g;
131 2         7 $s =~ s/\\t/\t/g;
132 2         7 $s =~ s/\\\\/\\/g;
133 2         7 $s =~ s{\\/}{/}g;
134 2         10 $s =~ s{\\"}{"}g;
135              
136 2         16 return $s;
137              
138             } # End of decode_string.
139              
140             # ------------------------------------------------
141              
142             sub eval_json
143             {
144 170     170 0 475 my($self, $thing) = @_;
145 170         297 my($type) = ref $thing;
146              
147 170 100       494 if ($type eq 'REF')
    100          
    100          
    100          
148             {
149 14         40 return \$self -> eval_json( ${$thing} );
  14         58  
150             }
151             elsif ($type eq 'ARRAY')
152             {
153 9         16 return [ map { $self -> eval_json($_) } @{$thing} ];
  12         32  
  9         28  
154             }
155             elsif ($type eq 'MarpaX::Demo::JSONParser::Actions::string')
156             {
157 102         226 my($string) = substr $thing->[0], 1, -1;
158              
159 102 100       244 return $self -> decode_string($string) if ( index $string, '\\' ) >= 0;
160 100         312 return $string;
161             }
162             elsif ($type eq 'MarpaX::Demo::JSONParser::Actions::hash')
163             {
164 20         71 return { map { $self -> eval_json( $_->[0] ), $self -> eval_json( $_->[1] ) } @{ $thing->[0] } };
  65         149  
  20         58  
165             }
166              
167 25 100       98 return 1 if $type eq 'MarpaX::Demo::JSONParser::Actions::true';
168 24 100       109 return '' if $type eq 'MarpaX::Demo::JSONParser::Actions::false';
169 21         79 return $thing;
170              
171             } # End of eval_json.
172              
173             # ------------------------------------------------
174              
175             sub parse
176             {
177 60     60 1 19313 my($self, $string) = @_;
178              
179 60 100       1109 if ($self -> base_name eq 'json.3.bnf')
180             {
181 20         414 my $parse_value = $self -> parser -> ($string);
182              
183 14         143325 return $self -> post_process(@{$parse_value});
  14         82  
184             }
185             else
186             {
187 40         888 $self -> scanner -> read(\$string);
188              
189 30         116472 my($value_ref) = $self -> scanner -> value;
190              
191 30 100       12835 die "Parse failed\n" if (! defined $value_ref);
192              
193 28 100       846 $value_ref = $self -> eval_json($value_ref) if ($self -> base_name eq 'json.2.bnf');
194              
195 28         281 return $$value_ref;
196             }
197              
198             } # End of parse.
199              
200             # ------------------------------------------------
201              
202             sub post_process
203             {
204 264     264 0 431 my ($self, $type, @value) = @_;
205              
206 264 100       458 return $value[0] if $type eq 'number';
207 245 100       379 return undef if $type eq 'null';
208 243 100       581 return $value[0] if $type eq 'easy string';
209 140 100       210 return $self -> unescape($value[0]) if $type eq 'any char';
210 136 100       250 return chr(hex(substr($value[0],2))) if $type eq 'hex char';
211 135 100       214 return 1 if $type eq 'true';
212 134 100       210 return q{} if $type eq 'false';
213              
214 131 100       191 if ($type eq 'array')
215             {
216 9         14 my @result = ();
217 9         15 push @result, $self -> post_process(@{$_}) for @{$value[0]};
  9         24  
  12         21  
218              
219 9         45 return \@result;
220             }
221              
222 122 100       193 if ($type eq 'hash')
223             {
224 20         35 my %result = ();
225              
226 20         32 for my $pair (@{$value[0]})
  20         36  
227             {
228 65         91 my $key = $self -> post_process(@{$pair->[0]});
  65         132  
229 65         96 $result{$key} = $self -> post_process(@{$pair->[1]});
  65         104  
230             }
231              
232 20         137 return \%result;
233             }
234              
235 102 50       156 if ($type eq 'string')
236             {
237 102         122 return join q{}, map { $self -> post_process( @{$_} ) } @{$value[0]};
  108         141  
  108         188  
  102         142  
238             }
239              
240 0         0 die join q{ }, 'post process failed:', $type, @value;
241              
242             } # End of post_process.
243              
244             # ------------------------------------------------
245              
246             sub unescape
247             {
248 4     4 0 9 my($self, $char) = @_;
249              
250 4 50       7 return "\b" if $char eq 'b';
251 4 50       10 return "\f" if $char eq 'f';
252 4 50       9 return "\n" if $char eq 'n';
253 4 50       7 return "\r" if $char eq 'r';
254 4 50       9 return "\t" if $char eq 't';
255 4 50       9 return '/' if $char eq '/';
256 4 50       8 return '\\' if $char eq '\\';
257 4 50       11 return '"' if $char eq '"';
258              
259             # If the character is not legal, return it anyway
260             # As an alternative, we could fail here.
261              
262 0           return $char;
263              
264             } # End of unescape.
265              
266             # ------------------------------------------------
267              
268             1;
269              
270             =pod
271              
272             =head1 NAME
273              
274             C - A JSON parser with a choice of grammars
275              
276             =head1 Synopsis
277              
278             #!/usr/bin/env perl
279              
280             use strict;
281             use warnings;
282              
283             use MarpaX::Demo::JSONParser;
284              
285             use Try::Tiny;
286              
287             my($app_name) = 'MarpaX-Demo-JSONParser';
288             my($bnf_name) = 'json.1.bnf'; # Or 'json.2.bnf'. See scripts/find.grammars.pl below.
289             my($bnf_file) = "data/$bnf_name";
290             my($string) = '{"test":"1.25e4"}';
291              
292             my($message);
293             my($result);
294              
295             # Use try to catch die.
296              
297             try
298             {
299             $message = '';
300             $result = MarpaX::Demo::JSONParser -> new(bnf_file => $bnf_file) -> parse($string);
301             }
302             catch
303             {
304             $message = $_;
305             $result = 0;
306             };
307              
308             print $result ? "Result: test => $$result{test}. Expect: 1.25e4. \n" : "Parse failed. $message";
309              
310             This script ships as scripts/demo.pl.
311              
312             You can test failure by deleting the '{' character in line 17 of demo.pl and re-running it.
313              
314             See also t/basic.tests.t for more sample code.
315              
316             =head1 Description
317              
318             C demonstrates 2 grammars for parsing JSON.
319              
320             Only 1 grammar is loaded per run, as specified by the C option to C<< new() >>.
321              
322             See t/basic.tests.t for sample code.
323              
324             =head1 Installation
325              
326             Install C as you would for any C module:
327              
328             Run:
329              
330             cpanm MarpaX::Demo::JSONParser
331              
332             or run:
333              
334             sudo cpan MarpaX::Demo::JSONParser
335              
336             or unpack the distro, and then either:
337              
338             perl Build.PL
339             ./Build
340             ./Build test
341             sudo ./Build install
342              
343             or:
344              
345             perl Makefile.PL
346             make (or dmake or nmake)
347             make test
348             make install
349              
350             =head1 Constructor and Initialization
351              
352             C is called as C<< my($parser) = MarpaX::Demo::JSONParser -> new(k1 => v1, k2 => v2, ...) >>.
353              
354             It returns a new object of type C.
355              
356             Key-value pairs accepted in the parameter list (see corresponding methods for details
357             [e.g. bnf_file([$string])]):
358              
359             =over 4
360              
361             =item o bnf_file aUserGrammarFileName
362              
363             Specify the name of the file containing your Marpa::R2-style grammar.
364              
365             See data/json.1.bnf, data/json.2.bnf and data/json.3.bnf for the cases handled by the code.
366              
367             This option is mandatory.
368              
369             Default: ''.
370              
371             =back
372              
373             =head1 Methods
374              
375             =head2 parse($string)
376              
377             Parses the given $string using the grammar whose file name was provided by the C option to
378             C<< new() >>.
379              
380             Dies if the parse fails, or returns the result of the parse if it succeeded.
381              
382             =head1 Files Shipped with this Module
383              
384             =head2 Data Files
385              
386             These JSON grammars are discussed in the L below.
387              
388             =over 4
389              
390             =item o data/json.1.bnf
391              
392             This JSON grammar was devised by Peter Stuifzand.
393              
394             =item o data/json.2.bnf
395              
396             This JSON grammar was devised by Jeffrey Kegler.
397              
398             =item o data/json.3.bnf
399              
400             This JSON grammar was devised by Jeffrey Kegler.
401              
402             =back
403              
404             =head2 Scripts
405              
406             =over 4
407              
408             =item o scripts/demo.pl
409              
410             This program is exactly what is displayed in the L above.
411              
412             Before installation of this module, run it with:
413              
414             shell> perl -Ilib scripts/demo.pl
415              
416             And after installation, just use:
417              
418             shell> perl scripts/demo.pl
419              
420             =item o scripts/find.grammars.pl
421              
422             After installation of the module, run it with:
423              
424             shell> perl scripts/find.grammars.pl (Defaults to json.1.bnf)
425             shell> perl scripts/find.grammars.pl json.1.bnf
426              
427             Or use json.2.bnf or json.2.bnf.
428              
429             It will print the name of the path to given grammar file.
430              
431             =back
432              
433             =head1 FAQ
434              
435             =head2 Where are the grammar files actually installed?
436              
437             They are not installed (when the source code is). They are shipped in the data/ dir.
438              
439             I used to use L and L to install them, but Module::Install is now
440             unusable. See Changes for details.
441              
442             =head2 Which JSON BNF is best?
443              
444             This is not really a fair question. They were developed under different circumstances.
445              
446             =over 4
447              
448             =item o json.1.bnf is by Peter Stuifzand.
449              
450             json.1.bnf is the first attempt, when the Marpa SLIF still did not handle utf8. And it's meant to be a practical
451             grammar. The sophisticated test suite is his, too.
452              
453             =item o json.2.bnf is by Jeffrey Kegler, the author of L.
454              
455             json.2.bnf was written later, after Jeffey had a chance to study json.1.bnf. He used it to help optimise Marpa,
456             but with a minimal test suite, so it had a different purpose.
457              
458             I (Ron) converted their code into forms suitable for building this module.
459              
460             =item o json.3.bnf is by Jeffrey Kegler.
461              
462             He developed this in August, 2014, after recent significant progress in the writing of Marpa.
463              
464             =back
465              
466             =head2 Where is Marpa's Homepage?
467              
468             L.
469              
470             =head2 Are there any articles discussing Marpa?
471              
472             Yes, many by its author, and several others. See Marpa's homepage, just above, and:
473              
474             L, (in progress, by Peter Stuifzand and Ron Savage).
475              
476             L, by Peter Stuifzand.
477              
478             L, by Peter Stuifzand.
479              
480             L, by Ron Savage.
481              
482             =head1 See Also
483              
484             L.
485              
486             L.
487              
488             L.
489              
490             =head1 Machine-Readable Change Log
491              
492             The file Changes was converted into Changelog.ini by L.
493              
494             =head1 Repository
495              
496             L
497              
498             =head1 Version Numbers
499              
500             Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions.
501              
502             =head1 Support
503              
504             Email the author, or log a bug on RT:
505              
506             L.
507              
508             =head1 Author
509              
510             L was written by Ron Savage Iron@savage.net.auE> in 2013.
511              
512             Home page: L.
513              
514             =head1 Copyright
515              
516             Australian copyright (c) 2013, Ron Savage.
517              
518             All Programs of mine are 'OSI Certified Open Source Software';
519             you can redistribute them and/or modify them under the terms of
520             The Perl License, a copy of which is available at:
521             http://www.opensource.org/licenses/index.html
522              
523             =cut