File Coverage

blib/lib/Makefile/GraphViz.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Makefile::GraphViz;
2              
3 2     2   41004 use strict;
  2         3  
  2         89  
4 2     2   9 use warnings;
  2         4  
  2         69  
5 2     2   8 use vars qw($VERSION);
  2         3  
  2         111  
6              
7 2     2   2854 use GraphViz;
  0            
  0            
8             use base 'Makefile::Parser';
9              
10             $VERSION = '0.21';
11              
12             $Makefile::Parser::Strict = 0;
13              
14             our $IDCounter = 0;
15              
16             # ================================
17             # == Default values & functions ==
18             # ================================
19              
20             my %NormalNodeStyle = (
21             shape => 'box',
22             style => 'filled',
23             fillcolor => '#ffff99',
24             fontname => 'Arial',
25             fontsize => 10,
26             );
27              
28             my %VirNodeStyle = (
29             shape => 'plaintext'
30             );
31              
32             my %NormalEndNodeStyle = (
33             fillcolor => '#ccff99'
34             );
35              
36             my %VirEndNodeStyle = (
37             shape => 'plaintext',
38             fillcolor => '#ccff99'
39             );
40              
41             my %CmdStyle = (
42             shape => 'note',
43             style => 'filled',
44             fillcolor => '#dddddd',
45             fontname => 'Monospace',
46             fontsize => 8,
47             );
48              
49             my %EdgeStyle = ( color => 'red' );
50              
51             my %InitArgs = (
52             layout => 'dot',
53             ratio => 'auto',
54             rankdir => 'BT',
55             node => \%NormalNodeStyle,
56             edge => \%EdgeStyle,
57             );
58              
59             our %Nodes;
60              
61             sub _gen_id () {
62             return ++$IDCounter;
63             }
64              
65             sub _trim_path ($) {
66             my $path = shift;
67             $path =~ s/.+(.{5}[\\\/].*)$/...$1/o;
68             $path =~ s/\\/\\\\/g;
69             return $path;
70             }
71              
72             sub _trim_cmd ($) {
73             my $cmd = shift;
74             $cmd =~ s/((?:\S+\s+){2})\S.*/$1.../o;
75             $cmd =~ s/\\/\\\\/g;
76             return $cmd;
77             }
78              
79             sub _url ($) {
80             my $url = shift;
81             $url =~ s/[\/\\:. \t]+/_/g;
82             return $url;
83             }
84              
85             sub _find ($@) {
86             my $elem = shift;
87             foreach (@_) {
88             if (ref $_) {
89             return 1 if $elem =~ $_;
90             }
91             return 1 if $elem eq $_;
92             }
93             return undef;
94             }
95              
96             # Plot graph with single root target
97             sub plot ($$@) {
98              
99             # ==================================
100             # == Unnamed command line options ==
101             # ==================================
102              
103             # Self
104             my $self = shift;
105              
106             # Main/root target
107             my $root_name = shift;
108              
109             # ================================
110             # == Named command line options ==
111             # ================================
112              
113             my %opts = @_;
114             my $gv = $opts{gv};
115              
116             # Helper function for initialising undefined user options with defaults
117             my $init_opts = sub {
118             my $key = shift;
119             $opts{$key} = +shift unless $opts{$key} and ref $opts{$key};
120             };
121              
122             $init_opts->('init_args', \%InitArgs);
123             $init_opts->('normal_node_style', \%NormalNodeStyle);
124             $init_opts->('vir_node_style', \%VirNodeStyle);
125             $init_opts->('normal_end_node_style', \%NormalEndNodeStyle);
126             $init_opts->('vir_end_node_style', \%VirEndNodeStyle);
127             $init_opts->('cmd_style', \%CmdStyle);
128             $init_opts->('edge_style', \%EdgeStyle);
129             $init_opts->('node_trim_fct', \&_trim_path);
130             $init_opts->('cmd_trim_fct', \&_trim_cmd);
131             $init_opts->('url_fct', \&_url);
132              
133             $opts{init_args}{name} = qq("$root_name");
134             $opts{init_args}{node} = $opts{normal_node_style};
135             $opts{init_args}{edge} = \%{$opts{edge_style}};
136              
137             # =========================
138             # == Initialise GraphViz ==
139             # =========================
140              
141             # Do nothing if root node is in exclude list
142             return $gv if _find($root_name, @{$opts{exclude}}) and !_find($root_name, @{$opts{no_exclude}});
143              
144             # Create new graph object if necessary
145             if (!$gv) {
146             $gv = GraphViz->new(%{$opts{init_args}});
147             %Nodes = ();
148             }
149              
150             # ===========================================
151             # == Create graph, starting from root node ==
152             # ===========================================
153              
154             # Assume we have a normal node
155             my $is_virtual = 0;
156             # Do nothing if node has already been processed
157             if ($Nodes{$root_name}) {
158             return $gv;
159             }
160             # Add node to processed node list
161             $Nodes{$root_name} = 1;
162              
163             # Initialise root node list
164             my @roots = ($root_name and ref $root_name)
165             ? $root_name
166             : ($self->target($root_name));
167              
168             # INFO: Why a list? Because multiple definitions of the same target with
169             # different prerequisites and recipes (commands) can occur. In this case
170             # $self->target returns multiple target objects with the same name, but
171             # different properties. Run the test suite and uncomment the code below
172             # to see this happen.
173             #if (scalar(@roots) > 1) {
174             # warn "\n\@roots contains multiple entries\n" ;
175             # if ($root_name and ref $root_name) {
176             # warn " \$root_name is a reference\n" ;
177             # }
178             # else {
179             # warn " \$self->target(\$root_name) delivers >1 targets\n" ;
180             # for my $root (@roots) {
181             # my @p = $root->prereqs();
182             # my @c = $root->commands();
183             # warn " root = $root -> prereqs = @p / commands = @c\n";
184             # }
185             # }
186             #}
187              
188             # Trim node name
189             my $short_name = $opts{node_trim_fct}->($root_name);
190              
191             # Determine node type (normal or virtual)
192             if (_find($root_name, @{$opts{normal_nodes}})) {
193             # Node is member of normal nodes list -> normal
194             $is_virtual = 0;
195             } elsif (_find($root_name, @{$opts{vir_nodes}}) or @roots and !$roots[0]->commands) {
196             # Node is member of virtual nodes list or has no commands -> virtual
197             $is_virtual = 1;
198             }
199              
200             # Is there a make target for this node?
201             if (!@roots) {
202             # No -> node is a "tree leave" -> add node, then stop processing
203             $gv->add_node(
204             $root_name,
205             label => $short_name,
206             $is_virtual ? %{$opts{vir_node_style}} : ()
207             );
208             return $gv;
209             }
210              
211             # Loop through node list for current target
212             for my $root (@roots) {
213             # Get prerequisites
214             my @prereqs = $root->prereqs;
215             # Is target flagged to be an end node?
216             my $is_end_node = (_find($root_name, @{$opts{end_with}}) and !_find($root_name, @{$opts{no_end_with}})) ? 1 : 0;
217              
218             # Expandable end node (i.e. with prerequisites)?
219             if ($is_end_node and @prereqs) {
220             # Yes -> add end node with URL
221             $gv->add_node(
222             $root_name,
223             label => $short_name,
224             # Add URL because the user might want to create a set of interlinked
225             # graphs with each end node pointing to its sub-graph
226             URL => $opts{url_fct}->($root_name),
227             $is_virtual ? %{$opts{vir_end_node_style}} : %{$opts{normal_end_node_style}}
228             );
229             # Call user-defined hook in case she wants to do something with end nodes,
230             # such as collect their names and then recursively plot sub-graphs.
231             $opts{end_with_callback}->($root_name) if $opts{end_with_callback};
232             # Stop processing here (thus the name "end node")
233             #return $gv;
234             }
235             else {
236             # No-> ordinary node or end node without prerequisites -> add normal node
237             $gv->add_node(
238             $root_name,
239             label => $short_name,
240             $is_virtual ? %{$opts{vir_node_style}} : ()
241             );
242             }
243              
244             # Add command node displaying target's recipe if trim_mode is false
245             # and recipe exists. BTW, '\l' left-justifies each single line.
246             my $lower_node;
247             my @cmds = $root->commands;
248             if (!$opts{trim_mode} and @cmds) {
249             # Command node gets an auto-created ID as its name
250             $lower_node = _gen_id();
251             my $cmds = join("\\l", map { $opts{cmd_trim_fct}->($_); } @cmds);
252             $gv->add_node(
253             $lower_node,
254             label => $cmds . "\\l",
255             %{$opts{cmd_style}}
256             );
257             # The recipe points to its target (dashed line if virtual target)
258             $gv->add_edge(
259             $lower_node => $root_name,
260             $is_virtual ? (style => 'dashed') : ()
261             );
262             } else {
263             $lower_node = $root_name;
264             }
265              
266             # No further processing for end nodes
267             next if $is_end_node;
268              
269             # Check prerequisites
270             foreach (@prereqs) {
271             # Ignore prerequisites on exclude list or named "|"
272             next if $_ eq "|" or (_find($_, @{$opts{exclude}}) and !_find($_, @{$opts{no_exclude}}));
273             # The prerequisite points to its dependent target (dashed line if virtual target)
274             $gv->add_edge(
275             $_ => $lower_node,
276             $is_virtual ? (style => 'dashed') : ());
277             # Recurse into 'plot' for prerequisite
278             $self->plot($_, gv => $gv, @_);
279             }
280             }
281             return $gv;
282             }
283              
284             # Plot graph with multiple (all) root targets
285             sub plot_all ($) {
286             my $self = shift;
287             # TODO: Should we not also apply $opts{init_args} here?
288             my $gv = GraphViz->new(%InitArgs);
289             %Nodes = ();
290             for my $target ($self->roots) {
291             $self->plot($target, gv => $gv);
292             }
293             $gv;
294             }
295              
296             1;
297             __END__