File Coverage

blib/lib/GraphViz2/Marpa/Renderer/Graphviz.pm
Criterion Covered Total %
statement 18 91 19.7
branch 0 62 0.0
condition 0 5 0.0
subroutine 6 11 54.5
pod 3 4 75.0
total 27 173 15.6


line stmt bran cond sub pod time code
1             package GraphViz2::Marpa::Renderer::Graphviz;
2              
3 2     2   6 use strict;
  2         2  
  2         43  
4 2     2   5 use warnings;
  2         2  
  2         37  
5 2     2   6 use warnings qw(FATAL utf8); # Fatalize encoding glitches.
  2         1  
  2         44  
6              
7 2     2   1396 use Log::Handler;
  2         70138  
  2         9  
8              
9 2     2   1644 use Moo;
  2         14906  
  2         8  
10              
11 2     2   2888 use Types::Standard qw/Any Str/;
  2         97096  
  2         15  
12              
13             has logger =>
14             (
15             default => sub{return undef},
16             is => 'rw',
17             isa => Any,
18             required => 0,
19             );
20              
21             has maxlevel =>
22             (
23             default => sub{return 'info'},
24             is => 'rw',
25             isa => Str,
26             required => 0,
27             );
28              
29             has minlevel =>
30             (
31             default => sub{return 'error'},
32             is => 'rw',
33             isa => Str,
34             required => 0,
35             );
36              
37             has output_file =>
38             (
39             default => sub{return ''},
40             is => 'rw',
41             isa => Str,
42             required => 0,
43             );
44              
45             has tree =>
46             (
47             default => sub{return ''},
48             is => 'rw',
49             isa => Any,
50             required => 1,
51             );
52              
53              
54             our $VERSION = '2.09';
55              
56             # --------------------------------------------------
57              
58             sub BUILD
59             {
60 0     0 0   my($self) = @_;
61              
62 0 0         if (! defined $self -> logger)
63             {
64 0           $self -> logger(Log::Handler -> new);
65 0           $self -> logger -> add
66             (
67             screen =>
68             {
69             maxlevel => $self -> maxlevel,
70             message_layout => '%m',
71             minlevel => $self -> minlevel,
72             }
73             );
74             }
75              
76             } # End of BUILD.
77              
78             # --------------------------------------------------
79              
80             sub format_node
81             {
82 0     0 1   my($self, $node, $opts) = @_;
83 0           my($name) = $node -> name;
84 0           my($attributes) = $node -> attributes;
85 0           my($attr_string) = $self -> tree -> hashref2string($attributes);
86 0   0       my($type) = $$attributes{type} || '';
87 0 0         my($value) = defined($$attributes{value}) ? $$attributes{value} : ''; # Allow for node '0'.
88 0           my($dot_input) = $$opts{previous}{dot_input};
89 0           my($depth) = $$opts{_depth};
90 0           my(%ignore) = (graph => 1, prolog => 1, root => 1);
91 0           my($message) = "name: $name. type: $type. value: $value. depth: $depth\n";
92              
93 0           my($indent);
94             my($offset);
95              
96 0           $self -> log(debug => "Rendering. $message");
97              
98 0 0         if ($name eq 'attribute')
    0          
    0          
    0          
    0          
    0          
    0          
99             {
100 0           $$opts{previous}{attribute_count}++;
101              
102 0 0 0       $value = qq("$value") if ( ($value !~ /^<.+>$/s) && ($value !~ /^".*"/) );
103              
104             # Separate nodes and graph attrs.
105              
106 0 0         if ($$opts{previous}{name} eq 'node_id')
107             {
108 0           $dot_input .= "\n";
109             }
110              
111 0 0         if ($$opts{previous}{value} eq '[')
    0          
112             {
113 0           $indent = '';
114             }
115             elsif ($$opts{previous}{name} eq 'attribute')
116             {
117 0           $indent = ' ';
118             }
119             else
120             {
121 0           $indent = "\t" x ($depth - 2);
122             }
123              
124 0           $dot_input .= "$indent$type = $value";
125             }
126             elsif ($name eq 'class')
127             {
128 0           $indent = "\t" x ($depth - 2);
129 0 0         $dot_input .= "\n" if ($$opts{previous}{name} eq 'node_id'); # Separate classes and nodes.
130 0 0         $dot_input .= "\n\n" if ($$opts{previous}{name} =~ /(?:attribute|class)/); # Separate classes and attrs.
131 0           $dot_input .= "$indent$value";
132             }
133             elsif ($name eq 'edge_id')
134             {
135 0           $dot_input .= " $value";
136             }
137             elsif ($name eq 'literal')
138             {
139 0 0         $dot_input .= "\n" if ($value =~ /[{}]/);
140              
141 0 0         if ($value =~ /[{}]/)
    0          
    0          
    0          
142             {
143 0           $indent = "\t" x ($depth - 2);
144 0 0         $indent .= "\n$indent" if ($$opts{previous}{name} eq 'edge_id'); # Separate edge from subgraph.
145 0           $dot_input .= "$indent$value\n";
146             }
147             elsif ($value =~ /[\[\]]/)
148             {
149 0 0         $$opts{previous}{attribute_count} = 0 if ($value eq '[');
150              
151 0           $indent = '';
152 0           $dot_input .= "$indent$value";
153 0 0         $dot_input .= "\n" if ($value eq ']'); # Separate attrs and other things.
154             }
155             elsif ($type =~ /^(?:digraph|graph|strict)_literal$/) # Must match 'graph' but not 'subgraph'!
156             {
157 0           $dot_input .= "$value ";
158             }
159             elsif ($type eq 'subgraph_literal')
160             {
161 0           $indent = "\t" x ($depth - 2);
162 0 0         $dot_input .= "\n" if ($$opts{previous}{name} eq 'attribute');
163 0           $dot_input .= "\n$indent$value ";
164             }
165             else
166             {
167 0           die "Rendering error: Unknown literal. $message";
168             }
169             }
170             elsif ($name =~ /(?:graph_id|node_id)/)
171             {
172 0           $indent = "\t" x ($depth - 2);
173 0 0         $dot_input .= "\n" if ($$opts{previous}{name} =~ /(?:attribute|class)/); # Separate classes and attrs.
174              
175 0 0         if ($$opts{previous}{name} eq 'edge_id')
    0          
    0          
176             {
177 0           $indent = ' '; # Don't separate nodes and edges.
178             }
179             elsif ($$opts{previous}{type} =~ /(?:digraph|graph)_literal/)
180             {
181 0           $indent = ''; # Don't separate nodes and 'digraph' or 'graph'.
182             }
183             elsif ($$opts{previous}{name} ne 'literal')
184             {
185 0           $indent = "\n$indent";
186             }
187              
188 0           $dot_input .= "$indent$value";
189             }
190             elsif ($name eq 'subgraph_id')
191             {
192 0           $dot_input .= " $value";
193             }
194             elsif (! $ignore{$name})
195             {
196 0           die "Rendering error: Unknown name. $message";
197             }
198              
199 0           $$opts{previous}{dot_input} = $dot_input;
200 0           $$opts{previous}{name} = $name;
201 0           $$opts{previous}{type} = $type;
202 0           $$opts{previous}{value} = $value;
203              
204             } # End of format_node.
205              
206             # --------------------------------------------------
207              
208             sub log
209             {
210 0     0 1   my($self, $level, $s) = @_;
211              
212 0 0         $self -> logger -> $level($s) if ($self -> logger);
213              
214             } # End of log.
215              
216             # --------------------------------------------------
217              
218             sub run
219             {
220 0     0 1   my($self) = @_;
221 0           my($previous) =
222             {
223             attribute_count => 0,
224             dot_input => '',
225             name => '',
226             type => '',
227             value => '',
228             };
229              
230             $self -> tree -> walk_down
231             ({
232             callback => sub
233             {
234 0     0     my($node, $opts) = @_;
235              
236             # Note: This $node is a Tree::DAG_Node node, not a Graphviz node.
237              
238 0           $self -> format_node($node, $opts);
239              
240             # Keep recursing.
241              
242 0           return 1;
243             },
244 0           _depth => 0,
245             previous => $previous,
246             });
247              
248 0           my($output_file) = $self -> output_file;
249              
250 0 0         if ($output_file)
251             {
252 0 0         open(my $fh, '> :encoding(utf-8)', $output_file) || die "Can't open(> $output_file): $!";
253 0           print $fh $$previous{dot_input};
254 0           close $fh;
255              
256 0           $self -> log(info => "Rendered file: $output_file");
257             }
258              
259             # Return 0 for success and 1 for failure.
260              
261 0           return 0;
262              
263             } # End of run.
264              
265             # --------------------------------------------------
266              
267             1;
268              
269             =pod
270              
271             =head1 NAME
272              
273             C - A renderer for L-style C files
274              
275             =head1 Synopsis
276              
277             See L.
278              
279             =head1 Description
280              
281             L provides a renderer for L (dot) graph definitions
282             parsed by L.
283              
284             It outputs a string to the output file, which (ideally) exactly matches the graph definition input to the paser,
285             although there might be small differences in the line-by-line formatting.
286              
287             This module is the default rendering engine for L.
288              
289             =head1 Installation
290              
291             Install L as you would for any C module:
292              
293             Run:
294              
295             cpanm GraphViz2::Marpa
296              
297             or run:
298              
299             sudo cpan GraphViz2::Marpa
300              
301             or unpack the distro, and then either:
302              
303             perl Build.PL
304             ./Build
305             ./Build test
306             sudo ./Build install
307              
308             or:
309              
310             perl Makefile.PL
311             make (or dmake or nmake)
312             make test
313             make install
314              
315             =head1 Constructor and Initialization
316              
317             C is called as C<< my($renderer) = GraphViz2::Marpa::Renderer::Graphviz -> new(k1 => v1, k2 => v2, ...) >>.
318              
319             It returns a new object of type C.
320              
321             Key-value pairs accepted in the parameter list (see corresponding methods for details
322             [e.g. maxlevel()]):
323              
324             =over 4
325              
326             =item o logger => $logger_object
327              
328             Specify a logger object.
329              
330             To disable logging, just set logger to the empty string.
331              
332             Default: An object of type L.
333              
334             =item o maxlevel => $level
335              
336             This option is only used if this module creates an object of type L. See L.
337              
338             Default: 'notice'.
339              
340             =item o minlevel => $level
341              
342             This option is only used if this module creates an object of type L. See L.
343              
344             Default: 'error'.
345              
346             No lower levels are used.
347              
348             =item o output_file => $file_name
349              
350             Specify the name of the output file to write. This will contain the text string of the rendered graph.
351              
352             Default: ''.
353              
354             The default means the output file is not written. Use the L method to retrieve the string.
355              
356             =item o tree => anObjectOfTypeTreeDAG_Node
357              
358             Specify the tree tokens output by the parser.
359              
360             This option is mandatory.
361              
362             The tree is output from L.
363              
364             Default: ''.
365              
366             =back
367              
368             =head1 Methods
369              
370             =head2 format_node($node, $opts)
371              
372             $node is an object of type L.
373              
374             $opts is the same hashref of options as passed in to the call to C in C.
375              
376             C is called to generate a string representation of $node, using $opts.
377              
378             Examine the default implementation of C, above, for more details.
379              
380             =head2 log($level, $s)
381              
382             Calls $self -> logger -> $level($s) if ($self -> logger).
383              
384             =head2 logger([$logger_object])
385              
386             Here, the [] indicate an optional parameter.
387              
388             Get or set the logger object.
389              
390             To disable logging, just set 'logger' to the empty string (not undef), in the call to L.
391              
392             'logger' is a parameter to L. See L for details.
393              
394             =head2 maxlevel([$string])
395              
396             Here, the [] indicate an optional parameter.
397              
398             Get or set the value used by the logger object.
399              
400             This option is only used if L or L
401             create an object of type L. See L.
402              
403             'maxlevel' is a parameter to L. See L for details.
404              
405             =head2 minlevel([$string])
406              
407             Here, the [] indicate an optional parameter.
408              
409             Get or set the value used by the logger object.
410              
411             This option is only used if L or L
412             create an object of type L. See L.
413              
414             'minlevel' is a parameter to L. See L for details.
415              
416             =head2 output_file([$file_name])
417              
418             Here, the [] indicate an optional parameter.
419              
420             Get or set the name of the output file. This will contain the text string of the rendered graph.
421              
422             If the output file name is not set, use the L method to retrieve the string.
423              
424             'output_file' is a parameter to L. See L for details.
425              
426             =head2 run()
427              
428             Renders the tree of parsed tokens as a string and, optionally, writes that string to the output file.
429              
430             Returns 0 for success and 1 for failure.
431              
432             =head2 tree()
433              
434             Gets or sets the tree of tokens to be rendered.
435              
436             'tree' is a parameter to L. See L for details.
437              
438             =head1 FAQ
439              
440             See L.
441              
442             =head1 Machine-Readable Change Log
443              
444             The file Changes was converted into Changelog.ini by L.
445              
446             =head1 Version Numbers
447              
448             Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions.
449              
450             =head1 Repository
451              
452             L
453              
454             =head1 Support
455              
456             Email the author, or log a bug on RT:
457              
458             L.
459              
460             =head1 Author
461              
462             L was written by Ron Savage Iron@savage.net.auE> in 2012.
463              
464             Home page: L.
465              
466             =head1 Copyright
467              
468             Australian copyright (c) 2012, Ron Savage.
469              
470             All Programs of mine are 'OSI Certified Open Source Software';
471             you can redistribute them and/or modify them under the terms of
472             The Perl License, a copy of which is available at:
473             http://dev.perl.org/licenses/
474              
475             =cut