File Coverage

blib/lib/Net/HostLanguage.pm
Criterion Covered Total %
statement 15 128 11.7
branch 0 34 0.0
condition 0 15 0.0
subroutine 5 16 31.2
pod 0 10 0.0
total 20 203 9.8


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__