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__ |