line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::HostLanguage; |
2
|
2
|
|
|
2
|
|
11
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
79
|
|
3
|
2
|
|
|
2
|
|
12
|
use warnings; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
60
|
|
4
|
|
|
|
|
|
|
|
5
|
2
|
|
|
2
|
|
1847
|
use Set::Scalar; |
|
2
|
|
|
|
|
26791
|
|
|
2
|
|
|
|
|
86
|
|
6
|
|
|
|
|
|
|
|
7
|
2
|
|
|
2
|
|
16
|
use base 'Exporter'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
303
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our @EXPORT = qw{ |
10
|
|
|
|
|
|
|
parse_configfile |
11
|
|
|
|
|
|
|
translate |
12
|
|
|
|
|
|
|
$VERBOSE |
13
|
|
|
|
|
|
|
}; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $VERBOSE = 0; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# Create methods for each defined machine or cluster |
18
|
|
|
|
|
|
|
sub create_machine_alias { |
19
|
0
|
|
|
0
|
0
|
|
my %cluster = @_; |
20
|
|
|
|
|
|
|
|
21
|
0
|
|
|
|
|
|
my %method; # keys: machine addresses. Values: the unique name of the associated method |
22
|
|
|
|
|
|
|
|
23
|
2
|
|
|
2
|
|
10
|
no strict 'refs'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
6890
|
|
24
|
0
|
|
|
|
|
|
for my $m (keys(%cluster)) { |
25
|
0
|
|
|
|
|
|
my $name = uniquename($m); |
26
|
0
|
|
|
|
|
|
*{__PACKAGE__.'::'.$name} = sub { |
27
|
0
|
|
|
0
|
|
|
$cluster{$m} |
28
|
0
|
|
|
|
|
|
}; |
29
|
0
|
|
|
|
|
|
$method{$m} = $name; |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
0
|
|
|
|
|
|
return \%method; |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# sub read_csshrc |
36
|
|
|
|
|
|
|
# Configuration dump produced by 'cssh -u' |
37
|
|
|
|
|
|
|
# Example of .csshrc file: |
38
|
|
|
|
|
|
|
# window_tiling=yes |
39
|
|
|
|
|
|
|
# window_tiling_direction=right |
40
|
|
|
|
|
|
|
# clusters = beno ben beo bno bco be bo eo et num beat local beow |
41
|
|
|
|
|
|
|
# beow = beowulf europa orion tegasaste |
42
|
|
|
|
|
|
|
# beno = beowulf europa nereida orion |
43
|
|
|
|
|
|
|
# ben = beowulf europa nereida |
44
|
|
|
|
|
|
|
# beo = beowulf europa orion |
45
|
|
|
|
|
|
|
# bno = beowulf nereida orion |
46
|
|
|
|
|
|
|
# bco = beowulf casnereida orion |
47
|
|
|
|
|
|
|
# be = beowulf europa |
48
|
|
|
|
|
|
|
# bo = beowulf orion |
49
|
|
|
|
|
|
|
# eo = europa orion |
50
|
|
|
|
|
|
|
# et = europa etsii |
51
|
|
|
|
|
|
|
# # europa etsii |
52
|
|
|
|
|
|
|
# num = 193.145.105.175 193.145.101.246 |
53
|
|
|
|
|
|
|
# # With @ |
54
|
|
|
|
|
|
|
# beat = casiano@beowulf casiano@europa |
55
|
|
|
|
|
|
|
# local = local1 local2 local3 |
56
|
|
|
|
|
|
|
sub read_csshrc { |
57
|
0
|
|
|
0
|
0
|
|
my $configfile = shift; |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
|
open(my $f, $configfile); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# We are interested in lines matching 'option = values' |
62
|
0
|
|
|
|
|
|
my @desc = grep { m{^\s*(\S+)\s*=\s*(.*)} } <$f>; |
|
0
|
|
|
|
|
|
|
63
|
0
|
|
|
|
|
|
close($f); |
64
|
|
|
|
|
|
|
|
65
|
0
|
|
|
|
|
|
my %config = map { m{^\s*(\S+)\s*=\s*(.*)} } @desc; |
|
0
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# From cssh man page: |
68
|
|
|
|
|
|
|
# extra_cluster_file = |
69
|
|
|
|
|
|
|
# Define an extra cluster file in the format of /etc/clusters. |
70
|
|
|
|
|
|
|
# Multiple files can be specified, seperated by commas. Both ~ and $HOME |
71
|
|
|
|
|
|
|
# are acceptable as a to reference the users home directory, i.e. |
72
|
|
|
|
|
|
|
# extra_cluster_file = ~/clusters, $HOME/clus |
73
|
|
|
|
|
|
|
# |
74
|
0
|
0
|
|
|
|
|
if (defined($config{extra_cluster_file})) { |
75
|
0
|
|
|
|
|
|
$config{extra_cluster_file} =~ s/(\~|\$HOME)/$ENV{HOME}/ge; |
|
0
|
|
|
|
|
|
|
76
|
0
|
|
|
|
|
|
my @extra = split /\s*,\s*/, $config{extra_cluster_file}; |
77
|
0
|
|
|
|
|
|
for my $extra (@extra) { |
78
|
0
|
0
|
|
|
|
|
if (-r $extra) { |
79
|
0
|
|
|
|
|
|
open(my $e, $extra); |
80
|
0
|
|
|
|
|
|
push @desc, grep { |
81
|
0
|
|
|
|
|
|
my $def = $_ =~ m{^\s*(\S+)\s*=\s*(.*)}; |
82
|
0
|
|
|
|
|
|
my $cl = $1; |
83
|
0
|
0
|
0
|
|
|
|
$config{clusters} .= " $cl" if ($cl && $config{clusters} !~ /\b$cl\b/); |
84
|
0
|
|
|
|
|
|
$def; |
85
|
|
|
|
|
|
|
} <$e>; |
86
|
0
|
|
|
|
|
|
close($e); |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
} |
90
|
0
|
|
|
|
|
|
chomp(@desc); |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# Get the clusters. It starts 'cluster = ... ' |
93
|
|
|
|
|
|
|
# clusters = beno ben beo bno bco be bo eo et num beat local beow |
94
|
0
|
|
|
|
|
|
my $regexp = $config{clusters}; |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# We create a regexp to search for the clusters definitions. |
97
|
|
|
|
|
|
|
# The regexp is the "or" of the cluster names followed by '=' |
98
|
|
|
|
|
|
|
# (^beo\s*=)|(^be\s*=) | ... |
99
|
0
|
|
|
|
|
|
$regexp =~ s/\s*(\S+)\s*/(^$1\\s*=)|/g; |
100
|
|
|
|
|
|
|
# (beno\s*=) | (ben\s*=) | ... | (beow\s*=) | |
101
|
|
|
|
|
|
|
# Chomp the final or '|' |
102
|
0
|
|
|
|
|
|
$regexp =~ s/[|]\s*$//; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Select the lines that correspond to clusters |
105
|
0
|
|
|
|
|
|
return grep { m{$regexp}x } @desc; |
|
0
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub slurp { |
109
|
0
|
|
|
0
|
0
|
|
my $configfile = shift; |
110
|
|
|
|
|
|
|
|
111
|
0
|
|
|
|
|
|
open(my $f, $configfile); |
112
|
0
|
|
|
|
|
|
my @desc = <$f>; |
113
|
0
|
|
|
|
|
|
chomp(@desc); |
114
|
|
|
|
|
|
|
|
115
|
0
|
|
|
|
|
|
return @desc; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# read_configfile: Return an array with the relevant lines of the config file |
119
|
|
|
|
|
|
|
sub read_configfile { |
120
|
0
|
|
|
0
|
0
|
|
my $configfile = $_[0]; |
121
|
|
|
|
|
|
|
|
122
|
0
|
0
|
0
|
|
|
|
return slurp($configfile) if (defined($configfile) && -r $configfile); |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# Configuration file not found. Try with ~/.clustersrc of cssh |
125
|
0
|
|
|
|
|
|
$configfile = $_[0] = "$ENV{HOME}/.clustersrc"; |
126
|
0
|
0
|
0
|
|
|
|
return slurp($configfile) if (defined($configfile) && -r $configfile); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# Configuration file not found. Try with ~/.csshrc of cssh |
129
|
0
|
|
|
|
|
|
$configfile = $_[0] = "$ENV{HOME}/.csshrc"; |
130
|
0
|
0
|
|
|
|
|
return read_csshrc($configfile) if (-r $configfile); |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# Configuration file not found. Try with /etc/clusters of cssh |
133
|
0
|
|
|
|
|
|
$configfile = $_[0] = "/etc/clusters"; |
134
|
0
|
0
|
|
|
|
|
return read_csshrc($configfile) if (-r $configfile); |
135
|
|
|
|
|
|
|
|
136
|
0
|
0
|
|
|
|
|
warn("Warning. Configuration file not found!\n") if $VERBOSE; |
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
|
|
|
return (); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
############################################################ |
142
|
|
|
|
|
|
|
# limitation: label expansion isn't allowed. Like in: |
143
|
|
|
|
|
|
|
# clusters = |
144
|
|
|
|
|
|
|
# = host1 host2 host3 |
145
|
|
|
|
|
|
|
# = user@host4 user@host5 host6 |
146
|
|
|
|
|
|
|
# = |
147
|
|
|
|
|
|
|
sub parse_configfile { |
148
|
0
|
|
|
0
|
0
|
|
my $configfile = $_[0]; |
149
|
0
|
|
|
|
|
|
my %cluster; |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
|
my @desc = read_configfile($_[0]); |
152
|
|
|
|
|
|
|
|
153
|
0
|
|
|
|
|
|
for (@desc) { |
154
|
0
|
0
|
|
|
|
|
next if /^\s*(#.*)?$/; |
155
|
|
|
|
|
|
|
|
156
|
0
|
|
|
|
|
|
my ($cluster, $members) = split /\s*=\s*/; |
157
|
0
|
0
|
|
|
|
|
die "Error in configuration file $configfile invalid cluster name $cluster" unless $cluster =~ /^[\w.]+$/; |
158
|
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
|
my @members = split /\s+/, $members; |
160
|
|
|
|
|
|
|
|
161
|
0
|
|
|
|
|
|
my @result; |
162
|
0
|
|
|
|
|
|
for my $m (@members) { |
163
|
0
|
0
|
|
|
|
|
die "Error in configuration file $_[0] invalid name $m" unless $m =~ /^[\@\w.]+$/; |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# Net::ParSCP admits cluster ranges as cc137..139 |
166
|
0
|
|
|
|
|
|
my $range = expand_ranges($m); |
167
|
0
|
|
|
|
|
|
push @result, $range->members; |
168
|
0
|
|
|
|
|
|
for my $r ($range->members) { |
169
|
0
|
0
|
|
|
|
|
$cluster{$r} = Set::Scalar->new($r) unless exists $cluster{$r}; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
} |
173
|
0
|
|
|
|
|
|
$cluster{$cluster} = Set::Scalar->new(@result); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# keys: machine and cluster names; values: name of the associated method |
177
|
0
|
|
|
|
|
|
my $method = create_machine_alias(%cluster); |
178
|
|
|
|
|
|
|
|
179
|
0
|
|
|
|
|
|
return (\%cluster, $method); |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
############################################################ |
183
|
|
|
|
|
|
|
{ |
184
|
|
|
|
|
|
|
my $pc = 0; |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub uniquename { |
187
|
0
|
|
|
0
|
0
|
|
my $m = shift; |
188
|
|
|
|
|
|
|
|
189
|
0
|
|
|
|
|
|
$m =~ s/\W/_/g; |
190
|
0
|
|
|
|
|
|
$pc++; |
191
|
0
|
|
|
|
|
|
return "_$pc"."_$m"; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub warnundefined { |
196
|
0
|
|
|
0
|
0
|
|
my ($configfile, @errors) = @_; |
197
|
|
|
|
|
|
|
|
198
|
0
|
|
|
|
|
|
local $" = ", "; |
199
|
0
|
0
|
|
|
|
|
my $prefix = (@errors > 1) ? |
200
|
|
|
|
|
|
|
"Machine identifiers (@errors) do" |
201
|
|
|
|
|
|
|
: "Machine identifier (@errors) does"; |
202
|
0
|
|
|
|
|
|
warn "$prefix not correspond to any cluster or machine defined in ". |
203
|
|
|
|
|
|
|
" cluster description file '$configfile'.\n"; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# expand_ranges |
207
|
|
|
|
|
|
|
# Receives a range (num...num) specifying a cluster like: |
208
|
|
|
|
|
|
|
# cc124..125.a1..2 |
209
|
|
|
|
|
|
|
# and returns the Set::Scalar object containing the elements: |
210
|
|
|
|
|
|
|
# cc124.a1 cc124.a2 cc125.a1 cc125.a2 |
211
|
|
|
|
|
|
|
sub expand_ranges { |
212
|
0
|
|
|
0
|
0
|
|
my $cluster = shift; |
213
|
|
|
|
|
|
|
|
214
|
0
|
|
|
|
|
|
my @result; |
215
|
0
|
|
|
|
|
|
my @processing = ($cluster); |
216
|
0
|
|
|
|
|
|
while (@processing) { |
217
|
0
|
|
|
|
|
|
my $c = shift @processing; |
218
|
0
|
|
|
|
|
|
my ($b, $e) = $c =~ m{(\d+)\.\.+(\d+)}; |
219
|
0
|
0
|
|
|
|
|
if (defined($b)) { |
220
|
0
|
|
|
|
|
|
@processing = map { my $d = $c; $d =~ s/$b\.\.+$e/$_/; $d } $b..$e; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
else { |
223
|
0
|
|
|
|
|
|
push @result, $c; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
0
|
|
|
|
|
|
return Set::Scalar->new(@result); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
sub non_declared_machines { |
230
|
0
|
|
|
0
|
0
|
|
my $configfile = shift; |
231
|
0
|
|
|
|
|
|
my $clusterexp = shift; |
232
|
0
|
|
|
|
|
|
my %cluster = @_; |
233
|
|
|
|
|
|
|
|
234
|
0
|
|
|
|
|
|
my @unknown; |
235
|
0
|
|
|
|
|
|
my @clusterexp = $clusterexp =~ m{([\w.\@]+)}g; |
236
|
0
|
0
|
|
|
|
|
if (@unknown = grep { !exists($cluster{$_}) } @clusterexp) { |
|
0
|
|
|
|
|
|
|
237
|
0
|
0
|
|
|
|
|
warnundefined($configfile, @unknown) if $VERBOSE; |
238
|
|
|
|
|
|
|
} |
239
|
0
|
|
|
|
|
|
return @unknown; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub translate { |
243
|
0
|
|
|
0
|
0
|
|
my ($configfile, $clusterexp, $cluster, $method) = @_; |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# Autodeclare unknown machine identifiers |
246
|
0
|
|
|
|
|
|
my @unknown = non_declared_machines($configfile, $clusterexp, %$cluster); |
247
|
0
|
|
|
|
|
|
my %unknown = map { $_ => expand_ranges($_)} @unknown; |
|
0
|
|
|
|
|
|
|
248
|
0
|
|
|
|
|
|
%$cluster = (%$cluster, %unknown); # union: add non declared machines |
249
|
0
|
|
|
|
|
|
%$method = (%$method, %{create_machine_alias(%unknown)}); |
|
0
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
# Translation: transform user's formula into a valid Perl expression |
252
|
|
|
|
|
|
|
# Cluster names are translated into a call to the associated method |
253
|
|
|
|
|
|
|
# The associated method returns the set of machines for that cluster |
254
|
0
|
|
|
|
|
|
$clusterexp =~ s/(\w[\w.\@]*)/$method->{$1}()/g; |
255
|
|
|
|
|
|
|
|
256
|
0
|
|
|
|
|
|
my $set = eval $clusterexp; |
257
|
|
|
|
|
|
|
|
258
|
0
|
0
|
0
|
|
|
|
unless (defined($set) && ref($set) && $set->isa('Set::Scalar')) { |
|
|
|
0
|
|
|
|
|
259
|
0
|
|
|
|
|
|
$clusterexp =~ s/_\d+_//g; |
260
|
0
|
|
|
|
|
|
$clusterexp =~ s/()//g; |
261
|
0
|
|
|
|
|
|
warn "Error. Expression '$clusterexp' has errors. Skipping.\n"; |
262
|
0
|
|
|
|
|
|
return; |
263
|
|
|
|
|
|
|
} |
264
|
0
|
|
|
|
|
|
return $set; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
1; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
__END__ |