File Coverage

blib/lib/MarpaX/Grammar/GraphViz2.pm
Criterion Covered Total %
statement 25 27 92.5
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 34 36 94.4


line stmt bran cond sub pod time code
1             package MarpaX::Grammar::GraphViz2;
2              
3 1     1   853 use strict;
  1         2  
  1         35  
4 1     1   1006 use utf8;
  1         12  
  1         6  
5 1     1   38 use warnings;
  1         5  
  1         39  
6 1     1   5 use warnings qw(FATAL utf8); # Fatalize encoding glitches.
  1         1  
  1         40  
7 1     1   832 use open qw(:std :utf8); # Undeclared streams in UTF-8.
  1         1284  
  1         5  
8 1     1   6582 use charnames qw(:full :short); # Unneeded in v5.16.
  1         43121  
  1         8  
9              
10 1     1   244 use File::Basename; # For basename().
  1         2  
  1         114  
11 1     1   934 use File::Which; # For which().
  1         1069  
  1         50  
12              
13 1     1   6630 use GraphViz2;
  0            
  0            
14              
15             use List::AllUtils qw/first_index indexes/;
16              
17             use Log::Handler;
18              
19             use MarpaX::Grammar::Parser;
20              
21             use Moo;
22              
23             has default_count =>
24             (
25             default => sub{return 0},
26             is => 'rw',
27             #isa => 'Int',
28             required => 0,
29             );
30              
31             has discard_count =>
32             (
33             default => sub{return 0},
34             is => 'rw',
35             #isa => 'Int',
36             required => 0,
37             );
38              
39             has driver =>
40             (
41             default => sub{return ''},
42             is => 'rw',
43             #isa => 'Str',
44             required => 0,
45             );
46              
47             has event_count =>
48             (
49             default => sub{return 0},
50             is => 'rw',
51             #isa => 'Int',
52             required => 0,
53             );
54              
55             has format =>
56             (
57             default => sub{return ''},
58             is => 'rw',
59             #isa => 'Str',
60             required => 0,
61             );
62              
63             has graph =>
64             (
65             default => sub{return ''},
66             is => 'rw',
67             #isa => 'GraphViz',
68             required => 0,
69             );
70              
71             has legend =>
72             (
73             default => sub{return 0},
74             is => 'rw',
75             #isa => 'Int',
76             required => 0,
77             );
78              
79             has lexeme_count =>
80             (
81             default => sub{return 0},
82             is => 'rw',
83             #isa => 'Int',
84             required => 0,
85             );
86              
87             has lexemes =>
88             (
89             default => sub{return {} },
90             is => 'rw',
91             #isa => 'HashRef',
92             required => 0,
93             );
94              
95             has logger =>
96             (
97             default => sub{return undef},
98             is => 'rw',
99             # isa => 'Str',
100             required => 0,
101             );
102              
103             has marpa_bnf_file =>
104             (
105             default => sub{return ''},
106             is => 'rw',
107             #isa => 'Str',
108             required => 1,
109             );
110              
111             has maxlevel =>
112             (
113             default => sub{return 'info'},
114             is => 'rw',
115             # isa => 'Str',
116             required => 0,
117             );
118              
119             has minlevel =>
120             (
121             default => sub{return 'error'},
122             is => 'rw',
123             # isa => 'Str',
124             required => 0,
125             );
126              
127             has nodes_seen =>
128             (
129             default => sub{return {}},
130             is => 'rw',
131             #isa => 'HashRef',
132             required => 0,
133             );
134              
135             has output_file =>
136             (
137             default => sub{return ''},
138             is => 'rw',
139             #isa => 'Str',
140             required => 0,
141             );
142              
143             has parser =>
144             (
145             default => sub{return ''},
146             is => 'rw',
147             #isa => 'MarpaX::Grammar::Parser',
148             required => 0,
149             );
150              
151             has root_node =>
152             (
153             default => sub{return ''},
154             is => 'rw',
155             #isa => 'Tree::DAG_Node',
156             required => 0,
157             );
158              
159             has separators =>
160             (
161             default => sub{return {} },
162             is => 'rw',
163             #isa => 'HashRef',
164             required => 0,
165             );
166              
167             has user_bnf_file =>
168             (
169             default => sub{return ''},
170             is => 'rw',
171             #isa => 'Str',
172             required => 1,
173             );
174              
175             our $VERSION = '1.00';
176              
177             # --------------------------------------------------
178              
179             sub add_legend
180             {
181             my($self) = @_;
182              
183             $self -> graph -> push_subgraph
184             (
185             # No options...
186             # Legend: top. Border: no. Label: no.
187             #
188             # label => 'cluster_legend',
189             # Legend: top. Border: no. Label: no.
190             #
191             # name => 'cluster_legend',
192             # Legend: top. Border: yes. Label: *.bnf.
193             #
194             #graph => {label => 'cluster_legend'},
195             # Legend: top. Border: no. Label: no. Not using subgraph => {...}.
196             #graph => {label => 'cluster_Legend'},
197             # Legend: bottom. Border: no. Label: no. Using subgraph => {...}.
198             # Legend: top. Border: no. Label: no. Not using subgraph => {...}.
199             subgraph => {rank => 'max'},
200             # Legend: top. Border: no. Label: no. Using graph => {...}.
201             # Legend: bottom. Border: no. Label: no. Not using graph => {...}.
202             );
203              
204             $self -> graph -> add_node
205             (
206             label =>
207             q|
208             <
209            
210             The green node is the start node
211            
212            
213             Lightblue nodes are for lexeme attributes
214            
215            
216             Orchid nodes are for lexemes
217            
218            
219             Golden nodes are for actions
220            
221            
222             Red nodes are for events
223            
224            
>
225             |,
226             name => 'Legend',
227             shape => 'plaintext',
228             );
229              
230             $self -> graph -> pop_subgraph;
231              
232             } # End of add_legend.
233              
234             # ------------------------------------------------
235              
236             sub add_node
237             {
238             my($self, %attributes) = @_;
239             my($name) = delete $attributes{name};
240             my($seen) = $self -> nodes_seen;
241              
242             $self -> graph -> add_node(name => $name, %attributes) if (! $$seen{$name});
243              
244             $$seen{$name} = 1;
245              
246             $self -> nodes_seen($seen);
247              
248             } # End of add_node.
249              
250             # ------------------------------------------------
251              
252             sub BUILD
253             {
254             my($self) = @_;
255              
256             die "No Marpa SLIF-DSL file found\n" if (! -e $self -> marpa_bnf_file);
257             die "No user SLIF-DSL file found\n" if (! -e $self -> user_bnf_file);
258              
259             $self -> driver($self -> driver || which('dot') );
260             $self -> format($self -> format || 'svg');
261              
262             if (! defined $self -> logger)
263             {
264             $self -> logger(Log::Handler -> new);
265             $self -> logger -> add
266             (
267             screen =>
268             {
269             maxlevel => $self -> maxlevel,
270             message_layout => '%m',
271             minlevel => $self -> minlevel,
272             }
273             );
274             }
275              
276             my($graph) ||= GraphViz2 -> new
277             (
278             edge => {color => 'grey'},
279             global => {directed => 1, driver => $self -> driver, format => $self -> format},
280             graph => {label => basename($self -> user_bnf_file), rankdir => 'TB'},
281             logger => $self -> logger,
282             node => {shape => 'rectangle', style => 'filled'},
283             );
284              
285             $self -> graph($graph);
286              
287             $self -> parser
288             (
289             MarpaX::Grammar::Parser -> new
290             (
291             marpa_bnf_file => $self -> marpa_bnf_file,
292             logger => $self -> logger,
293             user_bnf_file => $self -> user_bnf_file,
294             )
295             );
296              
297             } # End of BUILD.
298              
299             # --------------------------------------------------
300              
301             sub clean_name
302             {
303             my($self, $name, $skip_symbols) = @_;
304              
305             # If $skip_symbols is defined (as in calls from rectify_name() ),
306             # then do not do this check.
307              
308             return $name if ( (! defined $skip_symbols) && ($name =~ /(?::=|=>|=)/) );
309              
310             $name =~ s/\\/\\\\/g; # Escape \.
311             $name =~ s/
312             $name =~ s/>/\\>/g; # Escape >.
313             $name =~ s/:/\x{a789}/g; # Escape :.
314             $name =~ s/\"/\x{a78c}\x{a78c}/g; # Convert " into Unicode ' x 2.
315              
316             return $name;
317              
318             } # End of clean_name.
319              
320             # --------------------------------------------------
321              
322             sub clean_tree
323             {
324             my($self) = @_;
325              
326             my($attributes);
327             my($name);
328              
329             $self -> parser -> cooked_tree -> walk_down
330             ({
331             callback => sub
332             {
333             my($node, $options) = @_;
334             $name = $node -> name;
335             $attributes = $node -> attributes;
336              
337             $node -> attributes($attributes);
338             $node -> name($self -> clean_name($name) );
339              
340             return 1; # Keep walking.
341             },
342             _depth => 0,
343             });
344              
345             } # End of clean_tree.
346              
347             # --------------------------------------------------
348              
349             sub log
350             {
351             my($self, $level, $s) = @_;
352              
353             $self -> logger -> log($level => $s) if ($self -> logger);
354              
355             } # End of log.
356              
357             # --------------------------------------------------
358              
359             sub _process_adverbs
360             {
361             my($self, $daughters) = @_;
362             my($end) = $#$daughters;
363             my($separators) = $self -> separators;
364              
365             # Chop adverbs off the end of the list.
366              
367             my($adverb, @adverbs);
368             my(@token);
369              
370             while ($end > 0)
371             {
372             if ($$daughters[$end - 1] -> name eq '=>')
373             {
374             $adverb = $$daughters[$end - 2] -> name;
375             @token = $self -> rectify_name($$daughters[$end]);
376              
377             pop @$daughters for 1 .. 3;
378              
379             push @adverbs,
380             {
381             adverb => $adverb,
382             name => $token[0],
383             };
384              
385             $end = $#$daughters;
386             $$separators{$token[0]} = 1 if ($adverb eq 'separator');
387             }
388             else
389             {
390             $end = 0;
391             }
392             }
393              
394             # Construct the label as an array of hashrefs.
395              
396             if ($#adverbs >= 0)
397             {
398             @adverbs = map{"$$_{adverb} =\\> $$_{name}"} @adverbs;
399             $adverbs[0] = "\{$adverbs[0]";
400             $adverbs[$#adverbs] .= '}';
401             @adverbs = map{ {text => $_} } @adverbs;
402             }
403              
404             return ([@$daughters], [@adverbs]);
405              
406             } # End of _process_adverbs.
407              
408             # --------------------------------------------------
409             # This handles prioritized rules and quantized rules.
410              
411             sub _process_complex_adverbs
412             {
413             my($self, $index, $a_node) = @_;
414             my($finished) = 0;
415             my($daughters) = [$a_node -> daughters];
416              
417             # Sample inputs:
418             # o 1 token, no adverbs:
419             # |---number
420             # | |---~
421             # | |---int
422             # o 2 tokens, no adverbs:
423             # |---json
424             # | |---::=
425             # | |---object
426             # | |---|
427             # | |---array
428             # o 5 tokens, various adverbs:
429             # |---object
430             # | |---::=
431             # | |---'{'
432             # | |---'}'
433             # | |---action
434             # | |---=>
435             # | |---do_empty_object
436             # | |---|
437             # | |---'{'
438             # | |---members
439             # | |---'}'
440             # | |---action
441             # | |---=>
442             # | |---do_object
443              
444             my($adverbs, @adverb_stack);
445             my(@daughter_stack);
446             my(@token_stack);
447              
448             while (! $finished)
449             {
450             # Chew adverbs, if any, off the end of the list of daughters.
451              
452             ($daughters, $adverbs) = $self -> _process_adverbs($daughters);
453              
454             # Stack the adverbs owned by the token(s) at the end of the daughters.
455              
456             unshift @adverb_stack, $adverbs;
457              
458             # Chew the tokens owning the adverbs off the end of the list of daughters.
459             # This backward processing stops with a '|' or $daughter[0].
460              
461             @token_stack = ();
462              
463             my($i) = $#$daughters;
464              
465             while ( ($i > 0) && ($$daughters[$i] -> name ne '|') )
466             {
467             unshift @token_stack, pop @$daughters;
468              
469             $i--;
470             }
471              
472             unshift @daughter_stack, [@token_stack];
473              
474             # Discard the '|' separating alternatives in the SLIF-DSL.
475              
476             pop @$daughters if ($$daughters[$i] -> name eq '|');
477              
478             $finished = 1 if ($#$daughters == 0);
479             }
480              
481             return ([@daughter_stack], [@adverb_stack]);
482              
483             } # End of _process_complex_adverbs.
484              
485             # --------------------------------------------------
486              
487             sub _process_default_rule
488             {
489             my($self, $index, $a_node) = @_;
490              
491             $self -> default_count($self -> default_count + 1);
492              
493             my($default_count) = $self -> default_count;
494             my($default_name) = "\x{a789}default";
495             my($attributes) =
496             {
497             fillcolor => 'lightblue',
498             label => $default_name,
499             };
500              
501             if ($default_count == 1)
502             {
503             $self -> add_node(name => $default_name, %$attributes);
504             $self -> graph -> add_edge(from => $self -> root_node -> name, to => $default_name);
505             }
506              
507             my($daughters, $adverbs) = $self -> _process_adverbs([$a_node -> daughters]);
508              
509             if ($#$adverbs >= 0)
510             {
511             $$attributes{fillcolor} = 'goldenrod';
512             $$attributes{label} = $adverbs;
513             my($adverb_name) = "${default_name}_$default_count";
514              
515             $self -> add_node(name => $adverb_name, %$attributes);
516             $self -> graph -> add_edge(from => $default_name, to => $adverb_name);
517             }
518              
519             } # End of _process_default_rule.
520              
521             # --------------------------------------------------
522              
523             sub _process_discard_rule
524             {
525             my($self, $index, $a_node) = @_;
526              
527             $self -> discard_count($self -> discard_count + 1);
528              
529             my($discard_count) = $self -> discard_count;
530             my($discard_name) = "\x{a789}discard";
531             my($attributes) =
532             {
533             fillcolor => 'lightblue',
534             label => $discard_name,
535             };
536              
537             if ($discard_count == 1)
538             {
539             $self -> add_node(name => $discard_name, %$attributes);
540             $self -> graph -> add_edge(from => $self -> root_node -> name, to => $discard_name);
541             }
542              
543             # Ignore the first daughter, which is '=>'.
544              
545             my(@daughters) = $a_node -> daughters;
546             my(@name) = $self -> rectify_name($daughters[1]);
547             $$attributes{label} = $name[1];
548              
549             $self -> add_node(name => $name[0], %$attributes);
550             $self -> graph -> add_edge(from => $discard_name, to => $name[0]);
551              
552             } # End of _process_discard_rule.
553              
554             # --------------------------------------------------
555              
556             sub _process_event_rule
557             {
558             my($self, $index, $a_node) = @_;
559              
560             $self -> event_count($self -> event_count + 1);
561              
562             my($event_count) = $self -> event_count;
563             my($event_name) = 'event';
564             my($attributes) =
565             {
566             fillcolor => 'firebrick1',
567             label => $event_name,
568             };
569              
570             if ($event_count == 1)
571             {
572             $self -> add_node(name => $event_name, %$attributes);
573             $self -> graph -> add_edge(from => $self -> root_node -> name, to => $event_name);
574             }
575              
576             my($item_name) = "${event_name}_$event_count";
577             my(@daughters) = $a_node -> daughters;
578             my(@lhs) = $self -> rectify_name($daughters[3]);
579             $$attributes{label} =
580             [
581             {text => '{' . $daughters[0] -> name},
582             {text => $daughters[2] -> name},
583             {text => "$lhs[0]}"},
584             ];
585              
586             $self -> add_node(name => $item_name, %$attributes);
587             $self -> graph -> add_edge(from => $event_name, to => $item_name);
588             $self -> graph -> add_edge(from => $item_name, to => $lhs[0]);
589              
590             } # End of _process_event_rule.
591              
592             # --------------------------------------------------
593              
594             sub _process_lexeme_default_rule
595             {
596             my($self, $index, $a_node) = @_;
597             my($lexeme_name) = 'lexeme default';
598             my($attributes) =
599             {
600             fillcolor => 'lightblue',
601             label => $lexeme_name,
602             };
603              
604             $self -> add_node(name => $lexeme_name, %$attributes);
605             $self -> graph -> add_edge(from => $self -> root_node -> name, to => $lexeme_name);
606              
607             my($daughters, $adverbs) = $self -> _process_adverbs([$a_node -> daughters]);
608              
609             if ($#$adverbs >= 0)
610             {
611             $$attributes{label} = $adverbs;
612             my($adverb_name) = "${lexeme_name}_1";
613              
614             $self -> add_node(name => $adverb_name, %$attributes);
615             $self -> graph -> add_edge(from => $lexeme_name, to => $adverb_name);
616             }
617              
618             } # End of _process_lexeme_default_rule.
619              
620             # --------------------------------------------------
621              
622             sub _process_lexeme_rule
623             {
624             my($self, $index, $a_node) = @_;
625             my($daughters, $adverbs) = $self -> _process_adverbs([$a_node -> daughters]);
626             my(@name) = $self -> rectify_name($$daughters[1]);
627             my($lexeme) = $self -> lexemes;
628             $$lexeme{$name[0]} = $#$adverbs >= 0 ? $adverbs : '';
629              
630             $self -> lexemes($lexeme);
631              
632             } # End of _process_lexeme_rule.
633              
634             # --------------------------------------------------
635              
636             sub _process_lexeme_token
637             {
638             my($self, $index, $lexemes, $name, $label) = @_;
639              
640             my($attributes);
641              
642             if ($$lexemes{$name})
643             {
644             $attributes =
645             {
646             fillcolor => 'orchid',
647             label => [{text => "\{\x{a789}lexeme"}, {text => "$label}"}],
648             };
649             }
650             else
651             {
652             $attributes =
653             {
654             fillcolor => 'white',
655             label => $label,
656             };
657             }
658              
659             return $attributes;
660              
661             } # End of _process_lexeme_token.
662              
663             # --------------------------------------------------
664              
665             sub _process_normal_rule
666             {
667             my($self, $index, $a_node, $lexemes) = @_;
668             my($daughters, $adverbs) = $self -> _process_complex_adverbs($index, $a_node);
669              
670             for my $i (0 .. $#$daughters)
671             {
672             $self -> _process_normal_tokens($index, $a_node, $lexemes, $$daughters[$i], $$adverbs[$i]);
673             }
674              
675             } # End of _process_normal_rule.
676              
677             # --------------------------------------------------
678              
679             sub _process_normal_tokens
680             {
681             my($self, $index, $a_node, $lexemes, $daughters, $adverbs) = @_;
682              
683             # rectify_name() returns a set of ($name => $label) pairs.
684              
685             my(@name_map) = map{$self -> rectify_name($_)} @$daughters;
686             my(@name) = map{$name_map[$_]} indexes{$_ % 2 == 0} 0 .. $#name_map;
687             my(@label) = map{$name_map[$_]} indexes{$_ % 2 != 0} 0 .. $#name_map;
688             my($rule_name) = join(' ', @name);
689             my($rule_label) = join(' ', @label);
690             my($attributes) = $self -> _process_lexeme_token($index, $lexemes, $rule_name, $rule_label);
691             my(@parent) = $self -> rectify_name($a_node);
692              
693             $self -> add_node(name => $rule_name, %$attributes);
694             $self -> graph -> add_edge(from => $parent[0], to => $rule_name);
695              
696             my($attr_name);
697             my($name);
698              
699             for my $i (0 .. $#name)
700             {
701             $name = $name[$i];
702              
703             $attributes = $self -> _process_lexeme_token($index, $lexemes, $name, $label[$i]);
704              
705             # Don't re-add the node added just above.
706             # This happens in cases where there is just 1 daughter,
707             # which mean the join() above only had 1 name to 'join'.
708             # Nevertheless, after this 'if', we still add its attributes (outside the loop).
709              
710             if ($name ne $rule_name)
711             {
712             $self -> add_node(name => $name, %$attributes);
713             $self -> graph -> add_edge(from => $rule_name, to => $name);
714             }
715              
716             if ($$lexemes{$name})
717             {
718             $$attributes{fillcolor} = 'lightblue';
719             $$attributes{label} = $$lexemes{$name};
720             $attr_name = "${name}_$i";
721              
722             $self -> add_node(name => $attr_name, %$attributes);
723             $self -> graph -> add_edge(from => $name, to => $attr_name);
724             }
725             }
726              
727             if ($#$adverbs >= 0)
728             {
729             $$attributes{fillcolor} = 'goldenrod';
730             $$attributes{label} = $adverbs;
731             $attr_name = "${rule_name}_attributes";
732              
733             $self -> add_node(name => $attr_name, %$attributes);
734             $self -> graph -> add_edge(from => $rule_name, to => $attr_name);
735             }
736              
737             } # End of _process_normal_tokens.
738              
739             # --------------------------------------------------
740              
741             sub _process_start_rule
742             {
743             my($self, $index, $a_node) = @_;
744             my(@daughters) = $a_node -> daughters;
745             my(@name) = $self -> rectify_name($daughters[1]);
746              
747             $self -> root_node($daughters[1]);
748              
749             my($attributes) =
750             {
751             fillcolor => 'lightgreen',
752             label => [{text => '{:start'}, {text => "$name[1]}"}],
753             };
754              
755             $self -> add_node(name => $name[0], %$attributes);
756              
757             } # End of _process_start_rule.
758              
759             # --------------------------------------------------
760              
761             sub rectify_name
762             {
763             my($self, $node) = @_;
764             my($attributes) = $node -> attributes;
765             my($name) = $self -> clean_name($$attributes{real_name}, 1);
766             my($label) = $name . $$attributes{quantifier};
767              
768             return ($name, $label);
769              
770             } # End of rectify_name.
771              
772             # ------------------------------------------------
773              
774             sub run
775             {
776             my($self) = @_;
777             my($result) = $self -> parser -> run;
778              
779             # Return 0 for success and 1 for failure.
780              
781             return $result if ($result == 1);
782              
783             $self -> clean_tree;
784              
785             #$self -> log(debug => $_) for @{$self -> parser -> cooked_tree -> tree2string({no_attributes => 0})};
786              
787             my(@rule) = $self -> parser -> cooked_tree -> daughters;
788             my($start_index) = first_index{$_ -> name eq "\x{a789}start"} @rule;
789              
790             # Warning: This must be first because it sets $self -> root_node().
791              
792             $self -> _process_start_rule($start_index + 1, $rule[$start_index]);
793              
794             for my $index (indexes {$_ -> name eq "\x{a789}default"} @rule)
795             {
796             $self -> _process_default_rule($index + 1, $rule[$index]);
797             }
798              
799             for my $index (indexes {$_ -> name eq "\x{a789}discard"} @rule)
800             {
801             $self -> _process_discard_rule($index + 1, $rule[$index]);
802             }
803              
804             my($lexeme_default_index) = first_index{$_ -> name eq 'lexeme default'} @rule;
805              
806             $self -> _process_lexeme_default_rule($lexeme_default_index + 1, $rule[$lexeme_default_index]) if ($lexeme_default_index >= 0);
807              
808             for my $index (indexes {$_ -> name eq "\x{a789}lexeme"} @rule)
809             {
810             $self -> _process_lexeme_rule($index + 1, $rule[$index]);
811             }
812              
813             my(%seen) =
814             (
815             "\x{a789}default" => 1,
816             "\x{a789}discard" => 1,
817             'event' => 1, # Not yet, but we want process_normal_rule() to skip events.
818             "\x{a789}lexeme" => 1,
819             'lexeme default' => 1,
820             "\x{a789}start" => 1,
821             );
822              
823             my($lexemes) = $self -> lexemes;
824              
825             for my $index (0 .. $#rule)
826             {
827             next if ($seen{$rule[$index] -> name});
828              
829             $self -> _process_normal_rule($index + 1, $rule[$index], $lexemes);
830             }
831              
832             for my $index (indexes {$_ -> name eq 'event'} @rule)
833             {
834             $self -> _process_event_rule($index + 1, $rule[$index]);
835             }
836              
837             $self -> add_legend if ($self -> legend);
838              
839             my($output_file) = $self -> output_file;
840              
841             $self -> graph -> run(output_file => $output_file);
842              
843             # Return 0 for success and 1 for failure.
844              
845             return $result;
846              
847             } # End of run.
848              
849             # ------------------------------------------------
850              
851             1;
852              
853             =pod
854              
855             =encoding utf8
856              
857             =head1 NAME
858              
859             L - Convert a Marpa grammar into an image
860              
861             =head1 Synopsis
862              
863             use MarpaX::Grammar::GraphViz2;
864              
865             my(%option) =
866             ( # Inputs:
867             legend => 1,
868             marpa_bnf_file => 'share/metag.bnf',
869             user_bnf_file => 'share/stringparser.bnf',
870             # Outputs:
871             output_file => 'html/stringparser.svg',
872             );
873              
874             MarpaX::Grammar::GraphViz2 -> new(%option) -> run;
875              
876             See share/*.bnf for input files and html/*.svg for output files.
877              
878             For more help, run:
879              
880             shell> perl -Ilib scripts/bnf2graph.pl -h
881              
882             Note: Installation includes copying all files from the share/ directory, into a dir chosen by L.
883             Run scripts/find.grammars.pl to display the name of the latter dir.
884              
885             See also L.
886              
887             =head1 Description
888              
889             Process the output cooked tree from L, and turn it into an image.
890              
891             The tree holds a representation of the user's SLIF-DSL, and is managed by L.
892              
893             This modules uses L internally. It does not read that module's output file.
894              
895             =head1 Installation
896              
897             Install L as you would for any C module:
898              
899             Run:
900              
901             cpanm MarpaX::Grammar::GraphViz2
902              
903             or run:
904              
905             sudo cpan MarpaX::Grammar::GraphViz2
906              
907             or unpack the distro, and then either:
908              
909             perl Build.PL
910             ./Build
911             ./Build test
912             sudo ./Build install
913              
914             or:
915              
916             perl Makefile.PL
917             make (or dmake or nmake)
918             make test
919             make install
920              
921             Note: Installation includes copying all files from the share/ directory, into a dir chosen by L.
922             Run scripts/find.grammars.pl to display the name of the latter dir.
923              
924             =head1 Constructor and Initialization
925              
926             C is called as C<< my($parser) = MarpaX::Grammar::GraphViz2 -> new(k1 => v1, k2 => v2, ...) >>.
927              
928             It returns a new object of type C.
929              
930             Key-value pairs accepted in the parameter list (see also the corresponding methods
931             [e.g. L]):
932              
933             =over 4
934              
935             =item o driver aGraphvizDriverName
936              
937             The name of the Graphviz program to provide to L.
938              
939             Default: 'dot'.
940              
941             =item o format => $format_name
942              
943             This is the format of the output file, to be passed to L.
944              
945             Default: 'svg'.
946              
947             =item o graph => $graphviz2_object
948              
949             Provides an object of type L, to do the rendering.
950              
951             Default:
952              
953             GraphViz2 -> new
954             (
955             edge => {color => 'grey'},
956             global => {directed => 1, driver => $self -> driver, format => $self -> format},
957             graph => {label => basename($self -> user_bnf_file), rankdir => 'TB'},
958             logger => $self -> logger,
959             node => {shape => 'rectangle', style => 'filled'},
960             );
961              
962             =item o legend => $Boolean
963              
964             Add a legend (1) to the graph, or omit it (0).
965              
966             Default: 0.
967              
968             =item o logger => $logger_object
969              
970             Specify a logger object.
971              
972             The default value triggers creation of an object of type L which outputs to the screen.
973              
974             To disable logging, just set I to the empty string.
975              
976             The value for I is passed to L.
977              
978             Default: undef.
979              
980             =item o marpa_bnf_file aMarpaSLIF-DSLFileName
981              
982             Specify the name of Marpa's own SLIF-DSL file. This file ships with L. It's name is metag.bnf.
983              
984             A copy, as of Marpa::R2 V 2.068000, ships with C. See share/metag.bnf.
985              
986             This option is mandatory.
987              
988             Default: ''.
989              
990             =item o maxlevel => $level
991              
992             This option is only used if an object of type L is created. See I above.
993              
994             See also L.
995              
996             Default: 'info'. A typical value is 'debug'.
997              
998             =item o minlevel => $level
999              
1000             This option is only used if an object of type L is created. See I above.
1001              
1002             See also L.
1003              
1004             Default: 'error'.
1005              
1006             No lower levels are used.
1007              
1008             =item o output_file => $output_file_name
1009              
1010             Write the image to this file.
1011              
1012             Use the C option to specify the type of image desired.
1013              
1014             If '', the file is not written.
1015              
1016             Default: ''.
1017              
1018             =item o user_bnf_file aUserSLIF-DSLFileName
1019              
1020             Specify the name of the file containing your Marpa::R2-style grammar.
1021              
1022             See share/stringparser.bnf for a sample.
1023              
1024             This option is mandatory.
1025              
1026             Default: ''.
1027              
1028             =back
1029              
1030             =head1 Methods
1031              
1032             =head2 add_legend()
1033              
1034             Adds a legend to the graph if new() was called as C<< new(legend => 1) >>.
1035              
1036             =head2 add_node(%attributes)
1037              
1038             Adds (once only) a node to the graph. The node's name is C<$attributes{name}>.
1039              
1040             Also, adds that name to the hashref of node names seen, which is returned by L.
1041              
1042             =head2 clean_name($name, $skip_symbols)
1043              
1044             Cleans the given name to escape or replace characters special to L.
1045              
1046             Note: L also escapes some characters.
1047              
1048             $skip_symbols is used by the caller in 1 case to stop a regexp being activated.
1049              
1050             See the L for details.
1051              
1052             Returns the cleaned-up name.
1053              
1054             =head2 clean_tree()
1055              
1056             Calls L for each node in the tree.
1057              
1058             =head2 default_count()
1059              
1060             Returns the number of C<:default>' rules in the user's input.
1061              
1062             =head2 discard_count()
1063              
1064             Returns the number of C<:discard> rules in the user's input.
1065              
1066             =head2 driver([$executable_name])
1067              
1068             Here, the [] indicate an optional parameter.
1069              
1070             Get or set the name of the Graphviz program to provide to L.
1071              
1072             Note: C is a parameter to new().
1073              
1074             =head2 event_count()
1075              
1076             Returns the number of C rules in the user's input.
1077              
1078             =head2 format([$format])
1079              
1080             Here, the [] indicate an optional parameter.
1081              
1082             Get or set the format of the output file, to be created by the renderer.
1083              
1084             Note: C is a parameter to new().
1085              
1086             =head2 graph([$graph])
1087              
1088             Get of set the L object which will do the graphing.
1089              
1090             See also L.
1091              
1092             Note: C is a parameter to new().
1093              
1094             =head2 legend([$Boolean])
1095              
1096             Here, the [] indicate an optional parameter.
1097              
1098             Get or set the option to include (1) or exclude (0) a legend from the image.
1099              
1100             Note: C is a parameter to new().
1101              
1102             =head2 lexeme_count()
1103              
1104             Returns the number of C<:lexeme> rules in the user's input.
1105              
1106             =head2 lexemes()
1107              
1108             Returns a hashref keyed by the clean name, of lexemes seen in the user's input.
1109              
1110             The value for each key is an arrayref of hashrefs suitable for forcing L to plot the node as
1111             a record structure. See L for the gory details.
1112              
1113             =head2 log($level, $s)
1114              
1115             Calls $self -> logger -> log($level => $s) if ($self -> logger).
1116              
1117             =head2 logger([$logger_object])
1118              
1119             Here, the [] indicate an optional parameter.
1120              
1121             Get or set the logger object.
1122              
1123             To disable logging, just set logger to the empty string.
1124              
1125             This logger is passed to L.
1126              
1127             Note: C is a parameter to new().
1128              
1129             =head2 marpa_bnf_file([$bnf_file_name])
1130              
1131             Here, the [] indicate an optional parameter.
1132              
1133             Get or set the name of the file to read Marpa's grammar from.
1134              
1135             Note: C is a parameter to new().
1136              
1137             =head2 maxlevel([$string])
1138              
1139             Here, the [] indicate an optional parameter.
1140              
1141             Get or set the value used by the logger object.
1142              
1143             This option is only used if an object of type L is created. See L.
1144              
1145             Note: C is a parameter to new().
1146              
1147             =head2 minlevel([$string])
1148              
1149             Here, the [] indicate an optional parameter.
1150              
1151             Get or set the value used by the logger object.
1152              
1153             This option is only used if an object of type L is created. See L.
1154              
1155             Note: C is a parameter to new().
1156              
1157             =head2 new()
1158              
1159             The constructor. See L.
1160              
1161             =head2 nodes_seen()
1162              
1163             Returns a hashref keyed by the node name, of nodes passed to L.
1164              
1165             This is simply used to stop nodes being plotted twice.
1166              
1167             =head2 output_file([$output_file_name])
1168              
1169             Here, the [] indicate an optional parameter.
1170              
1171             Get or set the name of the file to which the renderer will write the resultant graph.
1172              
1173             If no output file is supplied, nothing is written.
1174              
1175             See also L.
1176              
1177             Note: C is a parameter to new().
1178              
1179             =head2 parser()
1180              
1181             Returns the L object which will do the analysis of the user's grammar.
1182              
1183             This object is created automatically during the call to L.
1184              
1185             =head2 rectify_node($node)
1186              
1187             For the given $node, which is an object of type L, clean it's real name.
1188              
1189             Then it adds the node's quantifier ('', '*' or '+') to that name, to act as the label (visible name) of the
1190             node, when the node is finally passed to L.
1191              
1192             Returns a 2-element list of ($name, $label).
1193              
1194             =head2 root_name()
1195              
1196             Returns an object of type L, representing the C<:start> token in the user's grammar.
1197              
1198             =head2 run()
1199              
1200             The method which does all the work.
1201              
1202             See L and scripts/bnf2graph.pl for sample code.
1203              
1204             =head2 separators()
1205              
1206             Returns a hashref keyed by token name, of tokens used in the grammar construct C<< separator => $token >>.
1207              
1208             This hashref is currently not used.
1209              
1210             =head1 Files Shipped with this Module
1211              
1212             =head2 Data Files
1213              
1214             =over 4
1215              
1216             =item o share/c.ast.bnf
1217              
1218             This is part of L, by Jean-Damien Durand. It's 1,565 lines long.
1219              
1220             =item o html/c.ast.svg
1221              
1222             This is the image from c.ast.bnf.
1223              
1224             See the next point for how this file is created.
1225              
1226             =item o share/c.ast.log
1227              
1228             This is the log produced by running the code at log level C:
1229              
1230             shell> scripts/bnf2graph.sh c.ast -max debug > share/c.ast.log
1231              
1232             =item o share/json.1.bnf
1233              
1234             It is part of L, written as a gist by Peter Stuifzand.
1235              
1236             See L.
1237              
1238             =item o html/json.1.svg
1239              
1240             This is the image from json.1.bnf.
1241              
1242             See the next point for how this file is created.
1243              
1244             =item o share/json.1.log
1245              
1246             This is the log produced by running the code at log level C:
1247              
1248             shell> scripts/bnf2graph.sh json.1 -max debug > share/json.1.log
1249              
1250             =item o share/json.2.bnf
1251              
1252             It also is part of L, written by Jeffrey Kegler as a reply to the gist above from Peter.
1253              
1254             =item o html/json.2.svg
1255              
1256             This is the image from json.2.bnf.
1257              
1258             See the next point for how this file is created.
1259              
1260             =item o share/json.2.log
1261              
1262             This is the log produced by running the code at log level C:
1263              
1264             shell> scripts/bnf2graph.sh json.2 -max debug > share/json.2.log
1265              
1266             =item o share/metag.bnf.
1267              
1268             This is a copy of L's SLIF-DSL, as of Marpa::R2 V 2.068000.
1269              
1270             See L above.
1271              
1272             =item o share/stringparser.bnf.
1273              
1274             This is a copy of L's SLIF-DSL.
1275              
1276             =item o html/stringparser.svg
1277              
1278             This is the image from stringparser.bnf.
1279              
1280             See the next point for how this file is created.
1281              
1282             =item o share/stringparser.log
1283              
1284             This is the log produced by running the code at log level C:
1285              
1286             shell> scripts/bnf2graph.sh stringparser -max debug > share/stringparser.log
1287              
1288             See L above.
1289              
1290             =item o share/termcap.info.bnf
1291              
1292             It also is part of L, written by Jean-Damien Durand.
1293              
1294             =item o html/termcap.info.svg
1295              
1296             This is the image from termcap.info.bnf.
1297              
1298             See the next point for how this file is created.
1299              
1300             =item o share/termcap.info.log
1301              
1302             This is the log produced by running the code at log level C:
1303              
1304             shell> scripts/bnf2graph.sh termcap.info -max debug > share/termcap.info.log
1305              
1306             =back
1307              
1308             =head2 Scripts
1309              
1310             =over 4
1311              
1312             =item o scripts/bnf2graph.pl
1313              
1314             This is a neat way of using the module. For help, run:
1315              
1316             shell> perl -Ilib scripts/bnf2graph.pl -h
1317              
1318             Of course you are also encouraged to include this module directly in your own code.
1319              
1320             =item o scripts/bnf2graph.sh
1321              
1322             This is a quick way for me to run bnf2graph.pl.
1323              
1324             =item o scripts/find.grammars.pl
1325              
1326             This prints the path to a grammar file. After installation of the module, run it with:
1327              
1328             shell> perl scripts/find.grammars.pl (Defaults to json.1.bnf)
1329             shell> perl scripts/find.grammars.pl c.ast.bnf
1330             shell> perl scripts/find.grammars.pl json.1.bnf
1331             shell> perl scripts/find.grammars.pl json.2.bnf
1332             shell> perl scripts/find.grammars.pl stringparser.bnf
1333             shell> perl scripts/find.grammars.pl termcap.inf.bnf
1334              
1335             It will print the name of the path to given grammar file.
1336              
1337             =item o scripts/generate.demo.pl
1338              
1339             Generates html/index.html.
1340              
1341             =item o scripts/generate.demo.sh
1342              
1343             This calls generate.demo.pl for each grammar shipped with the module.
1344              
1345             Actually, it skips c.ast by default, since it takes 6 m 47 s to run that. But if you pass any command line
1346             parameter to the script, it includes c.ast.
1347              
1348             Then it copies html/* to my web server's doc root (which is in Debian's default RAM disk) at /dev/shm/html.
1349              
1350             =item o scripts/pod2html.sh
1351              
1352             This lets me quickly proof-read edits to the docs.
1353              
1354             =back
1355              
1356             =head1 FAQ
1357              
1358             =head2 Why are some characters in the images replaced by Unicode versions?
1359              
1360             Firstly, the Perl module L escapes some characters. Currently, these are:
1361              
1362             [ ] " (in various circumstances)
1363              
1364             We let L handle these.
1365              
1366             Secondly, L itself treats some characters specially. Currently, these are:
1367              
1368             < > : "
1369              
1370             We use this code to handle these:
1371              
1372             $name =~ s/\\/\\\\/g; # Escape \.
1373             $name =~ s/
1374             $name =~ s/>/\\>/g; # Escape >.
1375             $name =~ s/:/\x{a789}/g; # Replace : with a Unicode :
1376             $name =~ s/\"/\x{a78c}\x{a78c}/g; # Replace " with 2 copies of a Unicode ' ...
1377             # ... because I could not find a Unicode ".
1378              
1379             =head2 Why do some images have a tiny sub-graph, whose root is, e.g., ''?
1380              
1381             This is due to the author using both 'comma' and '' as tokens within the grammar.
1382              
1383             So far this module does not handle that.
1384              
1385             A similar thing can happen elsewhere, e.g. with named event statements, when the rhs name uses (say) ''
1386             and the rule referred to uses just 'xyz'.
1387              
1388             In all such cases, there will be 2 nodes, with 2 names differing in just the brackets.
1389              
1390             =head2 Why do some nodes have (or lack) a quantifier when I use it both with and without one?
1391              
1392             There is simply no way to plot a node both with and without the quantifier. The one which appears is chosen
1393             arbitrarily, depending on how the code scans the grammar. This means it is currently beyond control.
1394              
1395             =head2 Why do the nodes on the demo page lack rule numbers?
1396              
1397             I'm undecided as to whether or not they are a good idea. I documented it on the demo page to indicate
1398             it was easy (for some nodes), and await feedback.
1399              
1400             =head2 Can I control the format or placement of the legend?
1401              
1402             No, but you can turn it off with the C option to C<< new() >>.
1403              
1404             =head1 ToDo
1405              
1406             =over 4
1407              
1408             =item o Perhaps add rule # to each node
1409              
1410             This is the rule # within the input stream. Doing this is simple for some nodes, and difficult for others.
1411              
1412             =back
1413              
1414             =head1 Machine-Readable Change Log
1415              
1416             The file Changes was converted into Changelog.ini by L.
1417              
1418             =head1 Version Numbers
1419              
1420             Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions.
1421              
1422             =head1 Support
1423              
1424             Email the author, or log a bug on RT:
1425              
1426             L.
1427              
1428             =head1 Author
1429              
1430             L was written by Ron Savage Iron@savage.net.auE> in 2013.
1431              
1432             Home page: L.
1433              
1434             =head1 Copyright
1435              
1436             Australian copyright (c) 2013, Ron Savage.
1437              
1438             All Programs of mine are 'OSI Certified Open Source Software';
1439             you can redistribute them and/or modify them under the terms of
1440             The Artistic License, a copy of which is available at:
1441             http://www.opensource.org/licenses/index.html
1442              
1443             =cut