File Coverage

blib/lib/Clustericious/Admin/Server.pm
Criterion Covered Total %
statement 96 116 82.7
branch 35 44 79.5
condition 12 14 85.7
subroutine 8 8 100.0
pod n/a
total 151 182 82.9


line stmt bran cond sub pod time code
1             package Clustericious::Admin::Server;
2              
3 3     3   21106 use strict;
  3         8  
  3         98  
4 3     3   18 use warnings;
  3         8  
  3         109  
5 3     3   667 use Sys::Hostname qw( hostname );
  3         1343  
  3         186  
6 3     3   20 use File::Temp qw( tempdir );
  3         9  
  3         158  
7 3     3   20 use File::Spec;
  3         7  
  3         99  
8 3     3   47 use File::Path qw( mkpath );
  3         10  
  3         3469  
9              
10             # ABSTRACT: Parallel SSH client server side code
11             our $VERSION = '1.10'; # VERSION
12              
13              
14             # This is the implementation of the clad server.
15             #
16             # - requires Perl 5.10
17             # - it is pure perl capable
18             # - no non-core requirements as of 5.14
19             # - single file implementation
20             # - optionally uses YAML::XS IF available
21             #
22             # The idea is that if App::clad is properly installed
23             # on the remote end, "clad --server" can be used to
24             # invoke, and you get YAML encoded payload. The YAML
25             # payload is preferred because it is easier to read
26             # when things go wrong. If App::clad is NOT installed
27             # on the remote end, then you can take this pm file,
28             # append the payload as Perl Dump after the __DATA__
29             # section below and send the server and payload and
30             # feed it into perl on the remote end.
31              
32             sub _decode
33             {
34 17     17   94 my(undef, $fh) = @_;
35 17         45 my $raw = do { local $/; <$fh> };
  17         92  
  17         427  
36              
37 17         57 my $payload;
38              
39 17 100       132 if($raw =~ /^---/)
    50          
40             {
41 16         47 eval {
42 16         101 require YAML::XS;
43 16         766 $payload = YAML::XS::Load($raw);
44             };
45 16 50       107 if(my $yaml_error = $@)
46             {
47 0         0 print STDERR "Clad Server: side YAML Error:\n";
48 0         0 print STDERR $yaml_error, "\n";
49 0         0 print STDERR "payload:\n";
50 0         0 print STDERR $raw, "\n";
51 0         0 return;
52             }
53 16 100       189 print STDERR YAML::XS::Dump($payload) if $payload->{verbose};
54             }
55             elsif($raw =~ /^#perl/)
56             {
57 0         0 $payload = eval $raw;
58 0 0       0 if(my $perl_error = $@)
59             {
60 0         0 print STDERR "Clad Server: side Perl Error:\n";
61 0         0 print STDERR $perl_error, "\n";
62 0         0 print STDERR "payload:\n";
63 0         0 print STDERR $raw, "\n";
64 0         0 return;
65             }
66 0         0 eval {
67 0         0 require Data::Dumper;
68 0 0       0 print Dumper($payload) if $payload->{verbose};
69             };
70             }
71             else
72             {
73 1         79 print STDERR "Clad Server: unable to detect encoding.\n";
74 1         19 print STDERR "payload:\n";
75 1         15 print STDERR $raw;
76             }
77            
78 17         101 $payload;
79             }
80              
81             sub _server
82             {
83 17   100 17   105 my $payload = _decode(@_) || return 2;
84            
85             # Payload:
86             #
87             # command: required, must be a array with at least one element
88             # the command to execute
89             #
90             # env: optional, must be a hash reference
91             # any environmental overrides
92             #
93             # verbose: optional true/false
94             # print out extra diagnostics
95             #
96             # version: required number or 'dev'
97             # the client version
98             #
99             # require: optional, number or 'dev'
100             # specifies the minimum required server
101             # server should die if requirement isn't met
102             # ignored if set to 'dev'
103             #
104             # files: optional list of hashref [ 1.01 ]
105             # each hashref has:
106             # name: the file basename (no directory)
107             # content: the content of the file
108             # mode: (optional) octal unix permission mode as a string (ie "0755" or "0644")
109             # env: (optional) environment variable to use instead of FILEx
110             #
111             # dir: optional hash of hash [ 1.02 ]
112             # each key is a path
113             # each value is a hash
114             # is_dir
115             # content
116             # mode
117             #
118             # stdin: optional scalar [ 1.04 ]
119              
120 16 100 100     122 if(ref $payload->{command} ne 'ARRAY' || @{ $payload->{command} } == 0)
  15         93  
121             {
122 2         138 print STDERR "Clad Server: Unable to find command\n";
123 2         25 return 2;
124             }
125            
126 14 100 100     100 if(defined $payload->{env} && ref $payload->{env} ne 'HASH')
127             {
128 1         53 print STDERR "Clad Server: env is not hash\n";
129 1         12 return 2;
130             }
131            
132 13 100       54 unless($payload->{version})
133             {
134 1         45 print STDERR "Clad Server: no client version\n";
135 1         8 return 2;
136             }
137            
138 12 100 66     84 if($payload->{require} && defined $Clustericious::Admin::Server::VERSION)
139             {
140 5 100 66     70 if($payload->{require} ne 'dev' && $payload->{require} > $Clustericious::Admin::Server::VERSION)
141             {
142 1         6 print STDERR "Clad Server: client requested version @{[ $payload->{require} ]} but this is only $Clustericious::Admin::Server::VERSION\n";
  1         83  
143 1         16 return 2;
144             }
145             }
146              
147 11 100       43 if($payload->{files})
148             {
149 2         8 my $count = 1;
150 2         5 foreach my $file (@{ $payload->{files} })
  2         9  
151             {
152 4         30 my $path = File::Spec->catfile( tempdir( CLEANUP => 1 ), $file->{name} );
153 4         3056 open my $fh, '>', $path;
154 4 50       118 chmod oct($file->{mode}), $path if defined $file->{mode};
155 4         22 binmode $fh;
156 4         44 print $fh $file->{content};
157 4         195 close $fh;
158 4         24 my $env = $file->{env};
159 4 100       26 $env = "FILE@{[ $count++ ]}" unless defined $env;
  2         12  
160 4         90 $ENV{$env} = $path;
161             }
162             }
163            
164 11 100       49 if($payload->{dir})
165             {
166 1         10 my $root = $ENV{DIR} = tempdir( CLEANUP => 1 );
167            
168 1         691 foreach my $name (sort keys %{ $payload->{dir} })
  1         14  
169             {
170 7         26 my $dir = $payload->{dir}->{$name};
171 7 100       29 next unless $dir->{is_dir};
172 5         51 my $path = File::Spec->catdir($root, $name);
173 5         333 mkdir $path;
174 5 100       83 chmod oct($dir->{mode}), $path if defined $dir->{mode};
175             }
176            
177 1         9 foreach my $name (sort keys %{ $payload->{dir} })
  1         11  
178             {
179 7         21 my $file = $payload->{dir}->{$name};
180 7 100       26 next if $file->{is_dir};
181 2         38 my $path = File::Spec->catfile($root, $name);
182 2         179 open my $fh, '>', $path;
183 2 50       64 chmod oct($file->{mode}), $fh if defined $file->{mode};
184 2         13 binmode $fh;
185 2         26 print $fh $file->{content};
186 2         90 close $fh;
187             }
188             }
189              
190 11         35 $ENV{$_} = $payload->{env}->{$_} for keys %{ $payload->{env} };
  11         92  
191            
192 11 50       53 if(defined $payload->{stdin})
193             {
194 0         0 my $filename = File::Spec->catfile(tempdir(CLEANUP => 1), 'stdin.txt');
195 0         0 open OUT, ">$filename";
196 0         0 print OUT $payload->{stdin};
197 0         0 close OUT;
198 0         0 open STDIN, "<$filename";
199             }
200            
201 11         29 system @{ $payload->{command} };
  11         208782  
202            
203 11 100       356 if($? == -1)
    100          
204             {
205 1         23 print STDERR "Clad Server: failed to execute on @{[ hostname ]}\n";
  1         23  
206 1         179 return 2;
207             }
208             elsif($? & 127)
209             {
210 1         19 print STDERR "Clad Server: died with signal @{[ $? & 127 ]} on @{[ hostname ]}\n";
  1         23  
  1         21  
211 1         106 return 2;
212             }
213            
214 9         715 return $? >> 8;
215             }
216              
217             exit __PACKAGE__->_server(*DATA) unless caller;
218              
219             1;
220              
221             =pod
222              
223             =encoding UTF-8
224              
225             =head1 NAME
226              
227             Clustericious::Admin::Server - Parallel SSH client server side code
228              
229             =head1 VERSION
230              
231             version 1.10
232              
233             =head1 SYNOPSIS
234              
235             % perldoc clad
236              
237             =head1 DESCRIPTION
238              
239             This module provides part of the implementation for the
240             L<clad> command. See the L<clad> command for the public
241             interface.
242              
243             =head1 SEE ALSO
244              
245             =over 4
246              
247             =item L<clad>
248              
249             =back
250              
251             =head1 AUTHOR
252              
253             Graham Ollis <plicease@cpan.org>
254              
255             =head1 COPYRIGHT AND LICENSE
256              
257             This software is copyright (c) 2015 by Graham Ollis.
258              
259             This is free software; you can redistribute it and/or modify it under
260             the same terms as the Perl 5 programming language system itself.
261              
262             =cut
263              
264             __DATA__