line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Apache::Logmonster::Utility; |
2
|
|
|
|
|
|
|
# ABSTRACT: utility subroutines for sysadmin tasks |
3
|
|
|
|
|
|
|
|
4
|
3
|
|
|
3
|
|
16
|
use strict; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
90
|
|
5
|
3
|
|
|
3
|
|
15
|
use warnings; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
124
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '5.35'; |
8
|
|
|
|
|
|
|
|
9
|
3
|
|
|
3
|
|
13
|
use Cwd; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
187
|
|
10
|
3
|
|
|
3
|
|
13
|
use Carp; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
149
|
|
11
|
3
|
|
|
3
|
|
837
|
use English qw( -no_match_vars ); |
|
3
|
|
|
|
|
4247
|
|
|
3
|
|
|
|
|
24
|
|
12
|
3
|
|
|
3
|
|
1296
|
use File::Basename; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
194
|
|
13
|
3
|
|
|
3
|
|
14
|
use File::Copy; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
113
|
|
14
|
3
|
|
|
3
|
|
13
|
use File::Path; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
128
|
|
15
|
3
|
|
|
3
|
|
73
|
use File::Spec; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
44
|
|
16
|
3
|
|
|
3
|
|
1710
|
use File::stat; |
|
3
|
|
|
|
|
14797
|
|
|
3
|
|
|
|
|
23
|
|
17
|
3
|
|
|
3
|
|
2739
|
use Params::Validate qw(:all); |
|
3
|
|
|
|
|
29718
|
|
|
3
|
|
|
|
|
657
|
|
18
|
3
|
|
|
3
|
|
25
|
use Scalar::Util qw( openhandle ); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
150
|
|
19
|
3
|
|
|
3
|
|
2476
|
use URI; |
|
3
|
|
|
|
|
13457
|
|
|
3
|
|
|
|
|
84
|
|
20
|
|
|
|
|
|
|
|
21
|
3
|
|
|
3
|
|
24
|
use lib 'lib'; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
26
|
|
22
|
3
|
|
|
3
|
|
352
|
use vars qw/ $log %std_opts /; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
1194
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub new { |
25
|
5
|
|
|
5
|
1
|
14
|
my $class = shift; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# globally scoped hash, populated with defaults as requested by the caller |
28
|
5
|
|
|
|
|
63
|
%std_opts = ( |
29
|
|
|
|
|
|
|
'fatal' => { type => BOOLEAN, optional => 1, default => 1 }, |
30
|
|
|
|
|
|
|
'debug' => { type => BOOLEAN, optional => 1, default => 1 }, |
31
|
|
|
|
|
|
|
'quiet' => { type => BOOLEAN, optional => 1, default => 0 }, |
32
|
|
|
|
|
|
|
'test_ok' => { type => BOOLEAN, optional => 1 }, |
33
|
|
|
|
|
|
|
); |
34
|
|
|
|
|
|
|
|
35
|
5
|
|
|
|
|
224
|
my %p = validate( @_, |
36
|
|
|
|
|
|
|
{ toaster=> { type => OBJECT, optional => 1 }, |
37
|
|
|
|
|
|
|
%std_opts, |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
); |
40
|
|
|
|
|
|
|
|
41
|
5
|
|
|
|
|
36
|
my $toaster = $p{toaster}; |
42
|
5
|
|
|
|
|
20
|
my $self = { |
43
|
|
|
|
|
|
|
debug => $p{debug}, |
44
|
|
|
|
|
|
|
fatal => $p{fatal}, |
45
|
|
|
|
|
|
|
}; |
46
|
5
|
|
|
|
|
14
|
bless $self, $class; |
47
|
|
|
|
|
|
|
|
48
|
5
|
|
|
|
|
22
|
$log = $self->{log} = $self; |
49
|
|
|
|
|
|
|
|
50
|
5
|
|
|
|
|
49
|
$log->audit( $class . sprintf( " loaded by %s, %s, %s", caller ) ); |
51
|
5
|
|
|
|
|
37
|
return $self; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub ask { |
55
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
56
|
0
|
|
|
|
|
0
|
my $question = shift; |
57
|
0
|
|
|
|
|
0
|
my %p = validate( |
58
|
|
|
|
|
|
|
@_, |
59
|
|
|
|
|
|
|
{ default => { type => SCALAR|UNDEF, optional => 1 }, |
60
|
|
|
|
|
|
|
timeout => { type => SCALAR, optional => 1 }, |
61
|
|
|
|
|
|
|
password => { type => BOOLEAN, optional => 1, default => 0 }, |
62
|
|
|
|
|
|
|
test_ok => { type => BOOLEAN, optional => 1 }, |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
); |
65
|
|
|
|
|
|
|
|
66
|
0
|
|
|
|
|
0
|
my $pass = $p{password}; |
67
|
0
|
|
|
|
|
0
|
my $default = $p{default}; |
68
|
|
|
|
|
|
|
|
69
|
0
|
0
|
|
|
|
0
|
if ( ! $self->is_interactive() ) { |
70
|
0
|
|
|
|
|
0
|
$log->audit( "not running interactively, can not prompt!"); |
71
|
0
|
|
|
|
|
0
|
return $default; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
0
|
0
|
|
|
|
0
|
return $log->error( "ask called with \'$question\' which looks unsafe." ) |
75
|
3
|
|
|
3
|
|
17
|
if $question !~ m{\A \p{Any}* \z}xms; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
55
|
|
76
|
|
|
|
|
|
|
|
77
|
0
|
|
|
|
|
0
|
my $response; |
78
|
|
|
|
|
|
|
|
79
|
0
|
0
|
|
|
|
0
|
return $p{test_ok} if defined $p{test_ok}; |
80
|
|
|
|
|
|
|
|
81
|
0
|
|
|
|
|
0
|
PROMPT: |
82
|
|
|
|
|
|
|
print "Please enter $question"; |
83
|
0
|
0
|
0
|
|
|
0
|
print " [$default]" if ( $default && !$pass ); |
84
|
0
|
|
|
|
|
0
|
print ": "; |
85
|
|
|
|
|
|
|
|
86
|
0
|
0
|
|
|
|
0
|
system "stty -echo" if $pass; |
87
|
|
|
|
|
|
|
|
88
|
0
|
0
|
|
|
|
0
|
if ( $p{timeout} ) { |
89
|
0
|
|
|
|
|
0
|
eval { |
90
|
0
|
|
|
0
|
|
0
|
local $SIG{ALRM} = sub { die "alarm\n" }; |
|
0
|
|
|
|
|
0
|
|
91
|
0
|
|
|
|
|
0
|
alarm $p{timeout}; |
92
|
0
|
|
|
|
|
0
|
$response = ; |
93
|
0
|
|
|
|
|
0
|
alarm 0; |
94
|
|
|
|
|
|
|
}; |
95
|
0
|
0
|
|
|
|
0
|
if ($EVAL_ERROR) { |
96
|
0
|
0
|
|
|
|
0
|
$EVAL_ERROR eq "alarm\n" ? print "timed out!\n" : warn; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
else { |
100
|
0
|
|
|
|
|
0
|
$response = ; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
0
|
0
|
|
|
|
0
|
if ( $pass ) { |
104
|
0
|
|
|
|
|
0
|
print "Please enter $question (confirm): "; |
105
|
0
|
|
|
|
|
0
|
my $response2 = ; |
106
|
0
|
0
|
|
|
|
0
|
unless ( $response eq $response2 ) { |
107
|
0
|
|
|
|
|
0
|
print "\nPasswords don't match, try again.\n"; |
108
|
0
|
|
|
|
|
0
|
goto PROMPT; |
109
|
|
|
|
|
|
|
} |
110
|
0
|
|
|
|
|
0
|
system "stty echo"; |
111
|
0
|
|
|
|
|
0
|
print "\n"; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
0
|
chomp $response; |
115
|
|
|
|
|
|
|
|
116
|
0
|
0
|
|
|
|
0
|
return $response if $response; # if they typed something, return it |
117
|
0
|
0
|
|
|
|
0
|
return $default if $default; # return the default, if available |
118
|
0
|
|
|
|
|
0
|
return ''; # return empty handed |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub audit { |
122
|
191
|
|
|
191
|
0
|
720
|
my $self = shift; |
123
|
191
|
|
|
|
|
373
|
my $mess = shift; |
124
|
|
|
|
|
|
|
|
125
|
191
|
|
|
|
|
9688
|
my %p = validate( @_, { %std_opts } ); |
126
|
|
|
|
|
|
|
|
127
|
191
|
50
|
|
|
|
1508
|
if ($mess) { |
128
|
191
|
|
|
|
|
284
|
push @{ $log->{audit} }, $mess; |
|
191
|
|
|
|
|
1992
|
|
129
|
191
|
100
|
100
|
|
|
37707
|
print "$mess\n" if $self->{debug} || $p{debug}; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
191
|
|
|
|
|
1101
|
return \$log->{audit}; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub archive_file { |
136
|
5
|
|
|
5
|
1
|
90736
|
my $self = shift; |
137
|
5
|
50
|
|
|
|
31
|
my $file = shift or return $log->error("missing filename in request"); |
138
|
5
|
|
|
|
|
424
|
my %p = validate( @_, |
139
|
|
|
|
|
|
|
{ 'sudo' => { type => BOOLEAN, optional => 1, default => 1 }, |
140
|
|
|
|
|
|
|
'mode' => { type => SCALAR, optional => 1 }, |
141
|
|
|
|
|
|
|
destdir => { type => SCALAR, optional => 1 }, |
142
|
|
|
|
|
|
|
%std_opts, |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
); |
145
|
|
|
|
|
|
|
|
146
|
5
|
|
|
|
|
81
|
my %args = $self->get_std_args( %p ); |
147
|
|
|
|
|
|
|
|
148
|
5
|
100
|
|
|
|
208
|
return $log->error( "file ($file) is missing!", %args ) |
149
|
|
|
|
|
|
|
if !-e $file; |
150
|
|
|
|
|
|
|
|
151
|
4
|
|
|
|
|
30
|
my $archive = $file . '.' . time; |
152
|
|
|
|
|
|
|
|
153
|
4
|
50
|
33
|
|
|
25
|
if ( $p{destdir} && -d $p{destdir} ) { |
154
|
0
|
|
|
|
|
0
|
my ($vol,$dirs,$file_wo_path) = File::Spec->splitpath( $archive ); |
155
|
0
|
|
|
|
|
0
|
$archive = File::Spec->catfile( $p{destdir}, $file_wo_path ); |
156
|
|
|
|
|
|
|
}; |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# see if we can write to both files (new & archive) with current user |
159
|
4
|
50
|
33
|
|
|
43
|
if ( $self->is_writable( $file, %args ) |
160
|
|
|
|
|
|
|
&& $self->is_writable( $archive, %args ) ) { |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# we have permission, use perl's native copy |
163
|
4
|
|
|
|
|
49
|
copy( $file, $archive ); |
164
|
4
|
50
|
|
|
|
3323
|
if ( -e $archive ) { |
165
|
4
|
|
|
|
|
56
|
$log->audit("archive_file: $file backed up to $archive"); |
166
|
4
|
50
|
|
|
|
21
|
$self->chmod( file => $file, mode => $p{mode}, %args ) if $p{mode}; |
167
|
4
|
|
|
|
|
47
|
return $archive; |
168
|
|
|
|
|
|
|
}; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# we failed with existing permissions, try to escalate |
172
|
0
|
0
|
0
|
|
|
0
|
$self->archive_file_sudo( $file ) if ( $p{sudo} && $< != 0 ); |
173
|
|
|
|
|
|
|
|
174
|
0
|
0
|
|
|
|
0
|
return $log->error( "backup of $file to $archive failed: $!", %args) |
175
|
|
|
|
|
|
|
if ! -e $archive; |
176
|
|
|
|
|
|
|
|
177
|
0
|
0
|
|
|
|
0
|
$self->chmod( file => $file, mode => $p{mode}, %args ) if $p{mode}; |
178
|
|
|
|
|
|
|
|
179
|
0
|
|
|
|
|
0
|
$log->audit("$file backed up to $archive"); |
180
|
0
|
|
|
|
|
0
|
return $archive; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub archive_file_sudo { |
184
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
185
|
0
|
|
|
|
|
0
|
my ($file, $archive) = @_; |
186
|
|
|
|
|
|
|
|
187
|
0
|
|
|
|
|
0
|
my $sudo = $self->sudo(); |
188
|
0
|
|
|
|
|
0
|
my $cp = $self->find_bin( 'cp',fatal=>0 ); |
189
|
|
|
|
|
|
|
|
190
|
0
|
0
|
0
|
|
|
0
|
if ( $sudo && $cp ) { |
191
|
0
|
|
|
|
|
0
|
return $self->syscmd( "$sudo $cp $file $archive",fatal=>0 ); |
192
|
|
|
|
|
|
|
} |
193
|
0
|
|
|
|
|
0
|
$log->error( "archive_file: sudo or cp was missing, could not escalate.",fatal=>0); |
194
|
0
|
|
|
|
|
0
|
return; |
195
|
|
|
|
|
|
|
}; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub chmod { |
198
|
3
|
|
|
3
|
1
|
1048
|
my $self = shift; |
199
|
3
|
|
|
|
|
284
|
my %p = validate( |
200
|
|
|
|
|
|
|
@_, |
201
|
|
|
|
|
|
|
{ 'file' => { type => SCALAR, optional => 1, }, |
202
|
|
|
|
|
|
|
'file_or_dir' => { type => SCALAR, optional => 1, }, |
203
|
|
|
|
|
|
|
'dir' => { type => SCALAR, optional => 1, }, |
204
|
|
|
|
|
|
|
'mode' => { type => SCALAR, optional => 0, }, |
205
|
|
|
|
|
|
|
'sudo' => { type => BOOLEAN, optional => 1, default => 0 }, |
206
|
|
|
|
|
|
|
%std_opts, |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
); |
209
|
|
|
|
|
|
|
|
210
|
3
|
|
|
|
|
40
|
my $mode = $p{mode}; |
211
|
3
|
|
|
|
|
23
|
my %args = $self->get_std_args( %p ); |
212
|
|
|
|
|
|
|
|
213
|
3
|
50
|
33
|
|
|
46
|
my $file = $p{file} || $p{file_or_dir} || $p{dir} |
214
|
|
|
|
|
|
|
or return $log->error( "invalid params to chmod in ". ref $self ); |
215
|
|
|
|
|
|
|
|
216
|
3
|
50
|
|
|
|
12
|
if ( $p{sudo} ) { |
217
|
0
|
|
|
|
|
0
|
my $chmod = $self->find_bin( 'chmod', debug => 0 ); |
218
|
0
|
|
|
|
|
0
|
my $sudo = $self->sudo(); |
219
|
0
|
0
|
|
|
|
0
|
$self->syscmd( "$sudo $chmod $mode $file", debug => 0 ) |
220
|
|
|
|
|
|
|
or return $log->error( "couldn't chmod $file: $!", %args ); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# note the conversion of ($mode) to an octal value. Very important! |
224
|
3
|
50
|
|
|
|
144
|
CORE::chmod( oct($mode), $file ) or |
225
|
|
|
|
|
|
|
return $log->error( "couldn't chmod $file: $!", %args); |
226
|
|
|
|
|
|
|
|
227
|
3
|
|
|
|
|
30
|
$log->audit("chmod $mode $file"); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub chown { |
231
|
3
|
|
|
3
|
1
|
9599
|
my $self = shift; |
232
|
3
|
|
|
|
|
14
|
my $file = shift; |
233
|
3
|
|
|
|
|
438
|
my %p = validate( @_, |
234
|
|
|
|
|
|
|
{ 'uid' => { type => SCALAR }, |
235
|
|
|
|
|
|
|
'gid' => { type => SCALAR }, |
236
|
|
|
|
|
|
|
'sudo' => { type => BOOLEAN, optional => 1 }, |
237
|
|
|
|
|
|
|
%std_opts, |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
); |
240
|
|
|
|
|
|
|
|
241
|
3
|
|
|
|
|
65
|
my %args = $self->get_std_args( %p ); |
242
|
3
|
|
|
|
|
15
|
my ( $uid, $gid, $sudo ) = ( $p{uid}, $p{gid}, $p{sudo} ); |
243
|
|
|
|
|
|
|
|
244
|
3
|
50
|
|
|
|
19
|
$file or return $log->error( "missing file or dir", %args ); |
245
|
3
|
50
|
|
|
|
87
|
return $log->error( "file $file does not exist!", %args ) if ! -e $file; |
246
|
|
|
|
|
|
|
|
247
|
3
|
|
|
|
|
28
|
$log->audit("chown: preparing to chown $uid $file"); |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
# sudo forces system chown instead of the perl builtin |
250
|
3
|
50
|
|
|
|
15
|
return $self->chown_system( $file, |
251
|
|
|
|
|
|
|
%args, |
252
|
|
|
|
|
|
|
user => $uid, |
253
|
|
|
|
|
|
|
group => $gid, |
254
|
|
|
|
|
|
|
) if $sudo; |
255
|
|
|
|
|
|
|
|
256
|
3
|
|
|
|
|
7
|
my ( $nuid, $ngid ); # if uid or gid is not numeric, convert it |
257
|
|
|
|
|
|
|
|
258
|
3
|
50
|
|
|
|
23
|
if ( $uid =~ /\A[0-9]+\z/ ) { |
259
|
0
|
|
|
|
|
0
|
$nuid = int($uid); |
260
|
0
|
|
|
|
|
0
|
$log->audit(" using $nuid from int($uid)"); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
else { |
263
|
3
|
|
|
|
|
279
|
$nuid = getpwnam($uid); |
264
|
3
|
100
|
|
|
|
40
|
return $log->error( "failed to get uid for $uid", %args) if ! defined $nuid; |
265
|
2
|
|
|
|
|
29
|
$log->audit(" converted $uid to a number: $nuid"); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
2
|
50
|
|
|
|
23
|
if ( $gid =~ /\A[0-9\-]+\z/ ) { |
269
|
0
|
|
|
|
|
0
|
$ngid = int( $gid ); |
270
|
0
|
|
|
|
|
0
|
$log->audit(" using $ngid from int($gid)"); |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
else { |
273
|
2
|
|
|
|
|
136
|
$ngid = getgrnam( $gid ); |
274
|
2
|
50
|
|
|
|
8
|
return $log->error( "failed to get gid for $gid", %args) if ! defined $ngid; |
275
|
2
|
|
|
|
|
22
|
$log->audit(" converted $gid to numeric: $ngid"); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
2
|
50
|
|
|
|
102
|
chown( $nuid, $ngid, $file ) |
279
|
|
|
|
|
|
|
or return $log->error( "couldn't chown $file: $!",%args); |
280
|
|
|
|
|
|
|
|
281
|
2
|
|
|
|
|
41
|
return 1; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
sub chown_system { |
285
|
1
|
|
|
1
|
1
|
66
|
my $self = shift; |
286
|
1
|
|
|
|
|
11
|
my $dir = shift; |
287
|
1
|
|
|
|
|
67
|
my %p = validate( @_, |
288
|
|
|
|
|
|
|
{ 'user' => { type => SCALAR, optional => 0, }, |
289
|
|
|
|
|
|
|
'group' => { type => SCALAR, optional => 1, }, |
290
|
|
|
|
|
|
|
'recurse' => { type => BOOLEAN, optional => 1, }, |
291
|
|
|
|
|
|
|
%std_opts, |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
); |
294
|
|
|
|
|
|
|
|
295
|
1
|
|
|
|
|
15
|
my ( $user, $group, $recurse ) = ( $p{user}, $p{group}, $p{recurse} ); |
296
|
1
|
|
|
|
|
22
|
my %args = $self->get_std_args( %p ); |
297
|
|
|
|
|
|
|
|
298
|
1
|
50
|
|
|
|
12
|
$dir or return $log->error( "missing file or dir", %args ); |
299
|
1
|
|
|
|
|
15
|
my $cmd = $self->find_bin( 'chown', %args ); |
300
|
|
|
|
|
|
|
|
301
|
1
|
50
|
|
|
|
38
|
$cmd .= " -R" if $recurse; |
302
|
1
|
|
|
|
|
14
|
$cmd .= " $user"; |
303
|
1
|
50
|
|
|
|
124
|
$cmd .= ":$group" if $group; |
304
|
1
|
|
|
|
|
11
|
$cmd .= " $dir"; |
305
|
|
|
|
|
|
|
|
306
|
1
|
|
|
|
|
23
|
$log->audit( "cmd: $cmd" ); |
307
|
|
|
|
|
|
|
|
308
|
1
|
50
|
|
|
|
36
|
$self->syscmd( $cmd, %args ) or |
309
|
|
|
|
|
|
|
return $log->error( "couldn't chown with $cmd: $!", %args); |
310
|
|
|
|
|
|
|
|
311
|
1
|
|
|
|
|
24
|
my $mess; |
312
|
1
|
50
|
|
|
|
14
|
$mess .= "Recursively " if $recurse; |
313
|
1
|
|
|
|
|
14
|
$mess .= "changed $dir to be owned by $user"; |
314
|
1
|
|
|
|
|
11
|
$log->audit( $mess ); |
315
|
|
|
|
|
|
|
|
316
|
1
|
|
|
|
|
63
|
return 1; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub clean_tmp_dir { |
320
|
3
|
|
|
3
|
1
|
1061
|
my $self = shift; |
321
|
3
|
50
|
|
|
|
43
|
my $dir = shift or die "missing dir name"; |
322
|
3
|
|
|
|
|
220
|
my %p = validate( @_, { %std_opts } ); |
323
|
|
|
|
|
|
|
|
324
|
3
|
|
|
|
|
67
|
my %args = $self->get_std_args( %p ); |
325
|
|
|
|
|
|
|
|
326
|
3
|
|
|
|
|
24411
|
my $before = cwd; # remember where we started |
327
|
|
|
|
|
|
|
|
328
|
3
|
50
|
|
|
|
211
|
return $log->error( "couldn't chdir to $dir: $!", %args) if !chdir $dir; |
329
|
|
|
|
|
|
|
|
330
|
3
|
|
|
|
|
94
|
foreach ( $self->get_dir_files( $dir ) ) { |
331
|
6
|
50
|
|
|
|
18
|
next unless $_; |
332
|
|
|
|
|
|
|
|
333
|
6
|
|
|
|
|
47
|
my ($file) = $_ =~ /^(.*)$/; |
334
|
|
|
|
|
|
|
|
335
|
6
|
|
|
|
|
53
|
$log->audit( "deleting file $file" ); |
336
|
|
|
|
|
|
|
|
337
|
6
|
100
|
|
|
|
193
|
if ( -f $file ) { |
|
|
50
|
|
|
|
|
|
338
|
4
|
50
|
|
|
|
463
|
unlink $file or |
339
|
|
|
|
|
|
|
$self->file_delete( $file, %args ); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
elsif ( -d $file ) { |
342
|
2
|
50
|
|
|
|
911
|
rmtree $file or return $log->error( "couldn't delete $file", %args); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
else { |
345
|
0
|
|
|
|
|
0
|
$log->audit( "Cannot delete unknown entity: $file" ); |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
3
|
|
|
|
|
46
|
chdir $before; |
350
|
3
|
|
|
|
|
131
|
return 1; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
sub cwd_source_dir { |
354
|
2
|
|
|
2
|
1
|
28
|
my $self = shift; |
355
|
2
|
50
|
|
|
|
14
|
my $dir = shift or die "missing dir in request\n"; |
356
|
2
|
|
|
|
|
63
|
my %p = validate( @_, |
357
|
|
|
|
|
|
|
{ 'src' => { type => SCALAR, optional => 1, }, |
358
|
|
|
|
|
|
|
'sudo' => { type => BOOLEAN, optional => 1, }, |
359
|
|
|
|
|
|
|
%std_opts, |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
); |
362
|
|
|
|
|
|
|
|
363
|
2
|
|
|
|
|
15
|
my ( $src, $sudo, ) = ( $p{src}, $p{sudo}, ); |
364
|
2
|
|
|
|
|
14
|
my %args = $self->get_std_args( %p ); |
365
|
|
|
|
|
|
|
|
366
|
2
|
50
|
66
|
|
|
78
|
return $log->error( "Something (other than a directory) is at $dir and " . |
367
|
|
|
|
|
|
|
"that's my build directory. Please remove it and try again!", %args ) |
368
|
|
|
|
|
|
|
if ( -e $dir && !-d $dir ); |
369
|
|
|
|
|
|
|
|
370
|
2
|
100
|
|
|
|
67
|
if ( !-d $dir ) { |
371
|
|
|
|
|
|
|
|
372
|
1
|
|
|
|
|
5
|
_try_mkdir( $dir ); # use the perl builtin mkdir |
373
|
|
|
|
|
|
|
|
374
|
1
|
50
|
|
|
|
31
|
if ( !-d $dir ) { |
375
|
0
|
|
|
|
|
0
|
$log->audit( "trying again with system mkdir..."); |
376
|
0
|
|
|
|
|
0
|
$self->mkdir_system( dir => $dir, %args); |
377
|
|
|
|
|
|
|
|
378
|
0
|
0
|
|
|
|
0
|
if ( !-d $dir ) { |
379
|
0
|
|
|
|
|
0
|
$log->audit( "trying one last time with $sudo mkdir -p...."); |
380
|
0
|
0
|
|
|
|
0
|
$self->mkdir_system( dir => $dir, sudo => 1, %args) |
381
|
|
|
|
|
|
|
or return $log->error("Couldn't create $dir.", %args); |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
2
|
50
|
|
|
|
44
|
chdir $dir or return $log->error( "failed to cd to $dir: $!", %args); |
387
|
2
|
|
|
|
|
20
|
return 1; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
sub dump_audit { |
391
|
13
|
|
|
13
|
0
|
972
|
my $self = shift; |
392
|
13
|
|
|
|
|
279
|
my %p = validate( @_, { %std_opts } ); |
393
|
|
|
|
|
|
|
|
394
|
13
|
50
|
|
|
|
152
|
my $audit = $log->{audit} or return; |
395
|
13
|
50
|
|
|
|
133
|
return if ! $log->{last_audit}; |
396
|
0
|
0
|
|
|
|
0
|
return if $log->{last_audit} == scalar @$audit; # nothing new |
397
|
|
|
|
|
|
|
|
398
|
0
|
0
|
|
|
|
0
|
if ( $p{quiet} ) { # hide/mask unreported messages |
399
|
0
|
|
|
|
|
0
|
$log->{last_audit} = scalar @$audit; |
400
|
0
|
|
|
|
|
0
|
$log->{last_error} = scalar @{ $log->{errors}}; |
|
0
|
|
|
|
|
0
|
|
401
|
0
|
|
|
|
|
0
|
return 1; |
402
|
|
|
|
|
|
|
}; |
403
|
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
0
|
print "\n\t\t\tAudit History Report \n\n"; |
405
|
0
|
|
|
|
|
0
|
for( my $i = $log->{last_audit}; $i < scalar @$audit; $i++ ) { |
406
|
0
|
|
|
|
|
0
|
print " $audit->[$i]\n"; |
407
|
0
|
|
|
|
|
0
|
$log->{last_audit}++; |
408
|
|
|
|
|
|
|
}; |
409
|
0
|
|
|
|
|
0
|
return 1; |
410
|
|
|
|
|
|
|
}; |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
sub dump_errors { |
413
|
10
|
|
|
10
|
0
|
19
|
my $self = shift; |
414
|
10
|
100
|
|
|
|
75
|
my $last_line = $log->{last_error} or return; |
415
|
|
|
|
|
|
|
|
416
|
8
|
50
|
|
|
|
19
|
return if $last_line == scalar @{ $log->{errors} }; # everything dumped |
|
8
|
|
|
|
|
60
|
|
417
|
|
|
|
|
|
|
|
418
|
8
|
|
|
|
|
1463
|
print "\n\t\t\t Error History Report \n\n"; |
419
|
8
|
|
|
|
|
22
|
my $i = 0; |
420
|
8
|
|
|
|
|
17
|
foreach ( @{ $log->{errors} } ) { |
|
8
|
|
|
|
|
54
|
|
421
|
73
|
|
|
|
|
86
|
$i++; |
422
|
73
|
100
|
|
|
|
326
|
next if $i < $last_line; |
423
|
21
|
|
|
|
|
102
|
my $msg = $_->{errmsg}; |
424
|
21
|
|
|
|
|
188
|
my $loc = " at $_->{errloc}"; |
425
|
21
|
|
|
|
|
711
|
print $msg; |
426
|
21
|
|
|
|
|
146
|
for (my $j=length($msg); $j < 90-length($loc); $j++) { print '.'; }; |
|
179
|
|
|
|
|
5912
|
|
427
|
21
|
|
|
|
|
3853
|
print " $loc\n"; |
428
|
|
|
|
|
|
|
}; |
429
|
8
|
|
|
|
|
239
|
print "\n"; |
430
|
8
|
|
|
|
|
45
|
$log->{last_error} = $i; |
431
|
8
|
|
|
|
|
28
|
return; |
432
|
|
|
|
|
|
|
}; |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
sub _try_mkdir { |
435
|
1
|
|
|
1
|
|
5
|
my ( $dir ) = @_; |
436
|
1
|
50
|
|
|
|
306
|
mkpath( $dir, 0, oct('0755') ) |
437
|
|
|
|
|
|
|
or return $log->error( "mkdir $dir failed: $!"); |
438
|
1
|
|
|
|
|
9
|
$log->audit( "created $dir"); |
439
|
1
|
|
|
|
|
2
|
return 1; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
sub error { |
443
|
16
|
|
|
16
|
0
|
102
|
my $self = shift; |
444
|
16
|
|
|
|
|
72
|
my $message = shift; |
445
|
16
|
|
|
|
|
1056
|
my %p = validate( @_, |
446
|
|
|
|
|
|
|
{ location => { type => SCALAR, optional => 1, }, |
447
|
|
|
|
|
|
|
%std_opts, |
448
|
|
|
|
|
|
|
}, |
449
|
|
|
|
|
|
|
); |
450
|
|
|
|
|
|
|
|
451
|
16
|
|
|
|
|
176
|
my $location = $p{location}; |
452
|
16
|
|
|
|
|
49
|
my $debug = $p{debug}; |
453
|
16
|
|
|
|
|
63
|
my $fatal = $p{fatal}; |
454
|
|
|
|
|
|
|
|
455
|
16
|
50
|
|
|
|
81
|
if ( $message ) { |
456
|
16
|
|
33
|
|
|
306
|
my @caller = $p{caller} || caller; |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# append message and location to the error stack |
459
|
16
|
|
66
|
|
|
47
|
push @{ $log->{errors} }, { |
|
16
|
|
|
|
|
391
|
|
460
|
|
|
|
|
|
|
errmsg => $message, |
461
|
|
|
|
|
|
|
errloc => $location || join( ", ", $caller[0], $caller[2] ), |
462
|
|
|
|
|
|
|
}; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
else { |
465
|
0
|
|
|
|
|
0
|
$message = @{ $log->{errors} }[-1]; |
|
0
|
|
|
|
|
0
|
|
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
16
|
100
|
66
|
|
|
132
|
if ( $debug || $fatal ) { |
469
|
10
|
|
|
|
|
87
|
$self->dump_audit(); |
470
|
10
|
|
|
|
|
74
|
$self->dump_errors(); |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
16
|
50
|
|
|
|
62
|
exit 1 if $fatal; |
474
|
16
|
|
|
|
|
528
|
return; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
sub extract_archive { |
478
|
2
|
|
|
2
|
1
|
9
|
my $self = shift; |
479
|
2
|
50
|
|
|
|
21
|
my $archive = shift or die "missing archive name"; |
480
|
2
|
|
|
|
|
65
|
my %p = validate( @_, { %std_opts } ); |
481
|
2
|
|
|
|
|
35
|
my %args = $self->get_std_args( %p ); |
482
|
|
|
|
|
|
|
|
483
|
2
|
|
|
|
|
5
|
my $r; |
484
|
|
|
|
|
|
|
|
485
|
2
|
100
|
|
|
|
116
|
if ( !-e $archive ) { |
486
|
1
|
50
|
|
|
|
78
|
if ( -e "$archive.tar.gz" ) { $archive = "$archive.tar.gz" } |
|
0
|
50
|
|
|
|
0
|
|
|
|
50
|
|
|
|
|
|
487
|
0
|
|
|
|
|
0
|
elsif ( -e "$archive.tgz" ) { $archive = "$archive.tgz" } |
488
|
0
|
|
|
|
|
0
|
elsif ( -e "$archive.tar.bz2" ) { $archive = "$archive.tar.bz2" } |
489
|
|
|
|
|
|
|
else { |
490
|
1
|
|
|
|
|
18
|
return $log->error( "file $archive is missing!", %args ); |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
1
|
|
|
|
|
11
|
$log->audit("found $archive"); |
495
|
|
|
|
|
|
|
|
496
|
1
|
|
|
|
|
6
|
$ENV{PATH} = '/bin:/usr/bin'; # do this or taint checks will blow up on `` |
497
|
|
|
|
|
|
|
|
498
|
1
|
50
|
|
|
|
13
|
return $log->error( "unknown archive type: $archive", %args ) |
499
|
|
|
|
|
|
|
if $archive !~ /[bz2|gz]$/; |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# find these binaries, we need them to inspect and expand the archive |
502
|
1
|
|
|
|
|
22
|
my $tar = $self->find_bin( 'tar', %args ); |
503
|
1
|
|
|
|
|
27
|
my $file = $self->find_bin( 'file', %args ); |
504
|
|
|
|
|
|
|
|
505
|
1
|
|
|
|
|
28
|
my %types = ( |
506
|
|
|
|
|
|
|
gzip => { bin => 'gunzip', content => 'gzip', }, |
507
|
|
|
|
|
|
|
bzip => { bin => 'bunzip2', content => 'b(un)?zip2', }, |
508
|
|
|
|
|
|
|
# on BSD bunzip2, on Linux bzip2 |
509
|
|
|
|
|
|
|
); |
510
|
|
|
|
|
|
|
|
511
|
1
|
50
|
|
|
|
43
|
my $type |
|
|
50
|
|
|
|
|
|
512
|
|
|
|
|
|
|
= $archive =~ /bz2$/ ? 'bzip' |
513
|
|
|
|
|
|
|
: $archive =~ /gz$/ ? 'gzip' |
514
|
|
|
|
|
|
|
: return $log->error( 'unknown archive type', %args); |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
# make sure the archive contents match the file extension |
517
|
1
|
50
|
|
|
|
9965
|
return $log->error( "$archive not a $type compressed file", %args) |
518
|
|
|
|
|
|
|
unless grep ( /$types{$type}{content}/, `$file $archive` ); |
519
|
|
|
|
|
|
|
|
520
|
1
|
|
|
|
|
57
|
my $bin = $self->find_bin( $types{$type}{bin}, %args); |
521
|
|
|
|
|
|
|
|
522
|
1
|
50
|
|
|
|
42
|
$self->syscmd( "$bin -c $archive | $tar -xf -" ) or return; |
523
|
|
|
|
|
|
|
|
524
|
1
|
|
|
|
|
40
|
$log->audit( "extracted $archive" ); |
525
|
1
|
|
|
|
|
83
|
return 1; |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
sub file_delete { |
529
|
6
|
|
|
6
|
1
|
547
|
my $self = shift; |
530
|
6
|
50
|
|
|
|
34
|
my $file = shift or die "missing file argument"; |
531
|
6
|
|
|
|
|
194
|
my %p = validate( @_, |
532
|
|
|
|
|
|
|
{ 'sudo' => { type => BOOLEAN, optional => 1, default => 0 }, |
533
|
|
|
|
|
|
|
%std_opts, |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
); |
536
|
|
|
|
|
|
|
|
537
|
6
|
|
|
|
|
64
|
my %args = $self->get_std_args( %p ); |
538
|
|
|
|
|
|
|
|
539
|
6
|
100
|
|
|
|
227
|
return $log->error( "$file does not exist", %args ) if !-e $file; |
540
|
|
|
|
|
|
|
|
541
|
5
|
50
|
|
|
|
123
|
if ( -w $file ) { |
542
|
5
|
|
|
|
|
31
|
$log->audit( "write permission to $file: ok" ); |
543
|
|
|
|
|
|
|
|
544
|
5
|
50
|
|
|
|
558
|
unlink $file or return $log->error( "failed to delete $file", %args ); |
545
|
|
|
|
|
|
|
|
546
|
5
|
|
|
|
|
25
|
$log->audit( "deleted: $file" ); |
547
|
5
|
|
|
|
|
58
|
return 1; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
0
|
0
|
|
|
|
0
|
if ( !$p{sudo} ) { # all done |
551
|
0
|
0
|
|
|
|
0
|
return -e $file ? undef : 1; |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
|
554
|
0
|
|
|
|
|
0
|
my $err = "trying with system rm"; |
555
|
0
|
|
|
|
|
0
|
my $rm_command = $self->find_bin( "rm", %args ); |
556
|
0
|
|
|
|
|
0
|
$rm_command .= " -f $file"; |
557
|
|
|
|
|
|
|
|
558
|
0
|
0
|
|
|
|
0
|
if ( $< != 0 ) { # we're not running as root |
559
|
0
|
|
|
|
|
0
|
my $sudo = $self->sudo( %args ); |
560
|
0
|
|
|
|
|
0
|
$rm_command = "$sudo $rm_command"; |
561
|
0
|
|
|
|
|
0
|
$err .= " (sudo)"; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
0
|
0
|
|
|
|
0
|
$self->syscmd( $rm_command, %args ) |
565
|
|
|
|
|
|
|
or return $log->error( $err, %args ); |
566
|
|
|
|
|
|
|
|
567
|
0
|
0
|
|
|
|
0
|
return -e $file ? 0 : 1; |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
sub file_is_newer { |
571
|
2
|
|
|
2
|
1
|
8
|
my $self = shift; |
572
|
2
|
|
|
|
|
80
|
my %p = validate( @_, |
573
|
|
|
|
|
|
|
{ f1 => { type => SCALAR }, |
574
|
|
|
|
|
|
|
f2 => { type => SCALAR }, |
575
|
|
|
|
|
|
|
%std_opts, |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
); |
578
|
|
|
|
|
|
|
|
579
|
2
|
|
|
|
|
24
|
my ( $file1, $file2 ) = ( $p{f1}, $p{f2} ); |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
# get file attributes via stat |
582
|
|
|
|
|
|
|
# (dev,ino,mode,nlink,uid,gid,rdev,size,atime,mtime,ctime,blksize,blocks) |
583
|
|
|
|
|
|
|
|
584
|
2
|
|
|
|
|
9
|
$log->audit( "checking age of $file1 and $file2" ); |
585
|
|
|
|
|
|
|
|
586
|
2
|
|
|
|
|
18
|
my $stat1 = stat($file1)->mtime; |
587
|
2
|
|
|
|
|
384
|
my $stat2 = stat($file2)->mtime; |
588
|
|
|
|
|
|
|
|
589
|
2
|
|
|
|
|
234
|
$log->audit( "timestamps are $stat1 and $stat2"); |
590
|
|
|
|
|
|
|
|
591
|
2
|
100
|
|
|
|
17
|
return 1 if ( $stat2 > $stat1 ); |
592
|
1
|
|
|
|
|
7
|
return; |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
# I could just: |
595
|
|
|
|
|
|
|
# |
596
|
|
|
|
|
|
|
# if ( stat($f1)[9] > stat($f2)[9] ) |
597
|
|
|
|
|
|
|
# |
598
|
|
|
|
|
|
|
# but that forces the reader to read the man page for stat |
599
|
|
|
|
|
|
|
# to see what's happening |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
sub file_read { |
603
|
7
|
|
|
7
|
1
|
22
|
my $self = shift; |
604
|
7
|
50
|
|
|
|
192
|
my $file = shift or return $log->error("missing filename in request"); |
605
|
7
|
|
|
|
|
215
|
my %p = validate( |
606
|
|
|
|
|
|
|
@_, |
607
|
|
|
|
|
|
|
{ 'max_lines' => { type => SCALAR, optional => 1 }, |
608
|
|
|
|
|
|
|
'max_length' => { type => SCALAR, optional => 1 }, |
609
|
|
|
|
|
|
|
%std_opts |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
); |
612
|
|
|
|
|
|
|
|
613
|
7
|
|
|
|
|
55
|
my ( $max_lines, $max_length ) = ( $p{max_lines}, $p{max_length} ); |
614
|
7
|
|
|
|
|
26
|
my %args = $self->get_std_args( %p ); |
615
|
|
|
|
|
|
|
|
616
|
7
|
50
|
|
|
|
148
|
return $log->error( "$file does not exist!", %args) if !-e $file; |
617
|
7
|
50
|
|
|
|
127
|
return $log->error( "$file is not readable", %args ) if !-r $file; |
618
|
|
|
|
|
|
|
|
619
|
7
|
50
|
|
|
|
360
|
open my $FILE, '<', $file or |
620
|
|
|
|
|
|
|
return $log->error( "could not open $file: $OS_ERROR", %args ); |
621
|
|
|
|
|
|
|
|
622
|
7
|
|
|
|
|
17
|
my ( $line, @lines ); |
623
|
|
|
|
|
|
|
|
624
|
7
|
50
|
|
|
|
20
|
if ( ! $max_lines) { |
625
|
7
|
|
|
|
|
396
|
chomp( @lines = <$FILE> ); |
626
|
7
|
|
|
|
|
85
|
close $FILE; |
627
|
7
|
|
|
|
|
145
|
return @lines; |
628
|
|
|
|
|
|
|
# TODO: make max_length work with slurp mode, without doing something ugly like |
629
|
|
|
|
|
|
|
# reading in the entire line and then truncating it. |
630
|
|
|
|
|
|
|
}; |
631
|
|
|
|
|
|
|
|
632
|
0
|
|
|
|
|
0
|
my $i = 0; |
633
|
0
|
|
|
|
|
0
|
while ( $i < $max_lines ) { |
634
|
0
|
0
|
|
|
|
0
|
if ($max_length) { $line = substr <$FILE>, 0, $max_length; } |
|
0
|
|
|
|
|
0
|
|
635
|
0
|
|
|
|
|
0
|
else { $line = <$FILE>; }; |
636
|
0
|
0
|
|
|
|
0
|
last if ! $line; |
637
|
0
|
0
|
|
|
|
0
|
last if eof $FILE; |
638
|
0
|
|
|
|
|
0
|
push @lines, $line; |
639
|
0
|
|
|
|
|
0
|
$i++; |
640
|
|
|
|
|
|
|
} |
641
|
0
|
|
|
|
|
0
|
chomp @lines; |
642
|
0
|
|
|
|
|
0
|
close $FILE; |
643
|
0
|
|
|
|
|
0
|
return @lines; |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
sub file_mode { |
647
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
648
|
1
|
|
|
|
|
35
|
my %p = validate( @_, |
649
|
|
|
|
|
|
|
{ 'file' => { type => SCALAR }, |
650
|
|
|
|
|
|
|
%std_opts |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
); |
653
|
|
|
|
|
|
|
|
654
|
1
|
|
|
|
|
15
|
my $file = $p{file}; |
655
|
1
|
|
|
|
|
5
|
my %args = $self->get_std_args( %p ); |
656
|
|
|
|
|
|
|
|
657
|
1
|
50
|
|
|
|
33
|
return $log->error( "file '$file' does not exist!", %args) |
658
|
|
|
|
|
|
|
if !-e $file; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# one way to get file mode (using File::mode) |
661
|
|
|
|
|
|
|
# my $raw_mode = stat($file)->[2]; |
662
|
|
|
|
|
|
|
## no critic |
663
|
1
|
|
|
|
|
10
|
my $mode = sprintf "%04o", stat($file)->[2] & 07777; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
# another way to get it |
666
|
|
|
|
|
|
|
# my $st = stat($file); |
667
|
|
|
|
|
|
|
# my $mode = sprintf "%lo", $st->mode & 07777; |
668
|
|
|
|
|
|
|
|
669
|
1
|
|
|
|
|
180
|
$log->audit( "file $file has mode: $mode" ); |
670
|
1
|
|
|
|
|
7
|
return $mode; |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
sub file_write { |
674
|
9
|
|
|
9
|
1
|
891
|
my $self = shift; |
675
|
9
|
50
|
|
|
|
47
|
my $file = shift or return $log->error("missing filename in request"); |
676
|
9
|
|
|
|
|
596
|
my %p = validate( |
677
|
|
|
|
|
|
|
@_, |
678
|
|
|
|
|
|
|
{ 'lines' => { type => ARRAYREF }, |
679
|
|
|
|
|
|
|
'append' => { type => BOOLEAN, optional => 1, default => 0 }, |
680
|
|
|
|
|
|
|
'mode' => { type => SCALAR, optional => 1 }, |
681
|
|
|
|
|
|
|
%std_opts |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
); |
684
|
|
|
|
|
|
|
|
685
|
9
|
|
|
|
|
146
|
my $append = $p{append}; |
686
|
9
|
|
|
|
|
24
|
my $lines = $p{lines}; |
687
|
9
|
|
|
|
|
63
|
my %args = $self->get_std_args( %p ); |
688
|
|
|
|
|
|
|
|
689
|
9
|
50
|
|
|
|
494
|
return $log->error( "oops, $file is a directory", %args) if -d $file; |
690
|
9
|
50
|
|
|
|
82
|
return $log->error( "oops, $file is not writable", %args ) |
691
|
|
|
|
|
|
|
if ( ! $self->is_writable( $file, %args) ); |
692
|
|
|
|
|
|
|
|
693
|
9
|
|
|
|
|
27
|
my $m = "wrote"; |
694
|
9
|
|
|
|
|
17
|
my $write_mode = '>'; # (over)write |
695
|
|
|
|
|
|
|
|
696
|
9
|
100
|
|
|
|
28
|
if ( $append ) { |
697
|
3
|
|
|
|
|
5
|
$m = "appended"; |
698
|
3
|
|
|
|
|
15
|
$write_mode = '>>'; |
699
|
3
|
50
|
|
|
|
67
|
if ( -f $file ) { |
700
|
3
|
50
|
|
|
|
37
|
copy $file, "$file.tmp" or return $log->error( |
701
|
|
|
|
|
|
|
"couldn't create $file.tmp for safe append", %args ); |
702
|
|
|
|
|
|
|
}; |
703
|
|
|
|
|
|
|
}; |
704
|
|
|
|
|
|
|
|
705
|
9
|
50
|
|
|
|
2427
|
open my $HANDLE, $write_mode, "$file.tmp" |
706
|
|
|
|
|
|
|
or return $log->error( "file_write: couldn't open $file: $!", %args ); |
707
|
|
|
|
|
|
|
|
708
|
9
|
|
|
|
|
19
|
my $c = 0; |
709
|
9
|
|
|
|
|
22
|
foreach ( @$lines ) { chomp; print $HANDLE "$_\n"; $c++ }; |
|
9
|
|
|
|
|
34
|
|
|
9
|
|
|
|
|
115
|
|
|
9
|
|
|
|
|
34
|
|
710
|
9
|
50
|
|
|
|
373
|
close $HANDLE or return $log->error( "couldn't close $file: $!", %args ); |
711
|
|
|
|
|
|
|
|
712
|
9
|
|
|
|
|
79
|
$log->audit( "file_write: $m $c lines to $file", %args ); |
713
|
|
|
|
|
|
|
|
714
|
9
|
50
|
|
|
|
98
|
move( "$file.tmp", $file ) |
715
|
|
|
|
|
|
|
or return $log->error(" unable to update $file", %args); |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
# set file permissions mode if requested |
718
|
9
|
50
|
0
|
|
|
1550
|
$self->chmod( file => $file, mode => $p{mode}, %args ) |
719
|
|
|
|
|
|
|
or return if $p{mode}; |
720
|
|
|
|
|
|
|
|
721
|
9
|
|
|
|
|
125
|
return 1; |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
sub files_diff { |
725
|
5
|
|
|
5
|
1
|
29
|
my $self = shift; |
726
|
5
|
|
|
|
|
876
|
my %p = validate( |
727
|
|
|
|
|
|
|
@_, |
728
|
|
|
|
|
|
|
{ f1 => { type => SCALAR }, |
729
|
|
|
|
|
|
|
f2 => { type => SCALAR }, |
730
|
|
|
|
|
|
|
type => { type => SCALAR, optional => 1, default => 'text' }, |
731
|
|
|
|
|
|
|
%std_opts, |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
); |
734
|
|
|
|
|
|
|
|
735
|
5
|
|
|
|
|
77
|
my ( $f1, $f2, $type ) = ( $p{f1}, $p{f2}, $p{type} ); |
736
|
5
|
|
|
|
|
32
|
my %args = $log->get_std_args(%p); |
737
|
|
|
|
|
|
|
|
738
|
5
|
50
|
33
|
|
|
284
|
if ( !-e $f1 || !-e $f2 ) { |
739
|
0
|
|
|
|
|
0
|
$log->error( "$f1 or $f2 does not exist!", %args ); |
740
|
0
|
|
|
|
|
0
|
return -1; |
741
|
|
|
|
|
|
|
}; |
742
|
|
|
|
|
|
|
|
743
|
5
|
100
|
|
|
|
54
|
return $self->files_diff_md5( $f1, $f2, \%args) |
744
|
|
|
|
|
|
|
if $type ne "text"; |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
### TODO |
747
|
|
|
|
|
|
|
# use file here to make sure files are ASCII |
748
|
|
|
|
|
|
|
# |
749
|
3
|
|
|
|
|
48
|
$log->audit("comparing ascii files $f1 and $f2 using diff", %args); |
750
|
|
|
|
|
|
|
|
751
|
3
|
|
|
|
|
155
|
my $diff = $self->find_bin( 'diff', %args ); |
752
|
3
|
|
|
|
|
27660
|
my $r = `$diff $f1 $f2`; |
753
|
3
|
|
|
|
|
43
|
chomp $r; |
754
|
3
|
|
|
|
|
304
|
return $r; |
755
|
|
|
|
|
|
|
}; |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
sub files_diff_md5 { |
758
|
2
|
|
|
2
|
0
|
15
|
my $self = shift; |
759
|
2
|
|
|
|
|
15
|
my ($f1, $f2, $args) = @_; |
760
|
|
|
|
|
|
|
|
761
|
2
|
|
|
|
|
33
|
$log->audit("comparing $f1 and $f2 using md5", %$args); |
762
|
|
|
|
|
|
|
|
763
|
2
|
|
|
|
|
12
|
eval { require Digest::MD5 }; |
|
2
|
|
|
|
|
34
|
|
764
|
2
|
50
|
|
|
|
15
|
return $log->error( "couldn't load Digest::MD5!", %$args ) |
765
|
|
|
|
|
|
|
if $EVAL_ERROR; |
766
|
|
|
|
|
|
|
|
767
|
2
|
|
|
|
|
22
|
$log->audit( "\t Digest::MD5 loaded", %$args ); |
768
|
|
|
|
|
|
|
|
769
|
2
|
|
|
|
|
10
|
my @md5sums; |
770
|
|
|
|
|
|
|
|
771
|
2
|
|
|
|
|
12
|
foreach my $f ( $f1, $f2 ) { |
772
|
4
|
|
|
|
|
11
|
my ( $sum, $changed ); |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
# if the md5 file exists |
775
|
4
|
100
|
|
|
|
132
|
if ( -f "$f.md5" ) { |
776
|
2
|
|
|
|
|
21
|
$sum = $self->file_read( "$f.md5", %$args ); |
777
|
2
|
|
|
|
|
12
|
$log->audit( " md5 file for $f exists", %$args ); |
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
# if the md5 file is missing, invalid, or older than the file, recompute it |
781
|
4
|
100
|
66
|
|
|
172
|
if ( ! -f "$f.md5" or $sum !~ /[0-9a-f]+/i or |
|
|
|
100
|
|
|
|
|
782
|
|
|
|
|
|
|
$self->file_is_newer( f1 => "$f.md5", f2 => $f, %$args ) |
783
|
|
|
|
|
|
|
) |
784
|
|
|
|
|
|
|
{ |
785
|
3
|
|
|
|
|
59
|
my $ctx = Digest::MD5->new; |
786
|
3
|
|
|
|
|
169
|
open my $FILE, '<', $f; |
787
|
3
|
|
|
|
|
109
|
$ctx->addfile(*$FILE); |
788
|
3
|
|
|
|
|
30
|
$sum = $ctx->hexdigest; |
789
|
3
|
|
|
|
|
40
|
close $FILE; |
790
|
3
|
|
|
|
|
12
|
$changed++; |
791
|
3
|
|
|
|
|
26
|
$log->audit(" calculated md5: $sum", %$args); |
792
|
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
|
|
794
|
4
|
|
|
|
|
13
|
push( @md5sums, $sum ); |
795
|
4
|
100
|
|
|
|
57
|
$self->file_write( "$f.md5", lines => [$sum], %$args ) if $changed; |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
|
798
|
2
|
100
|
|
|
|
22
|
return if $md5sums[0] eq $md5sums[1]; |
799
|
1
|
|
|
|
|
9
|
return 1; |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
sub find_bin { |
803
|
26
|
|
|
26
|
1
|
4071
|
my $self = shift; |
804
|
26
|
50
|
|
|
|
357
|
my $bin = shift or die "missing argument to find_bin\n"; |
805
|
26
|
|
|
|
|
1486
|
my %p = validate( @_, |
806
|
|
|
|
|
|
|
{ 'dir' => { type => SCALAR, optional => 1, }, |
807
|
|
|
|
|
|
|
%std_opts, |
808
|
|
|
|
|
|
|
}, |
809
|
|
|
|
|
|
|
); |
810
|
|
|
|
|
|
|
|
811
|
26
|
|
|
|
|
230
|
my $prefix = "/usr/local"; |
812
|
26
|
|
|
|
|
181
|
my %args = $log->get_std_args(%p); |
813
|
|
|
|
|
|
|
|
814
|
26
|
50
|
33
|
|
|
243
|
if ( $bin =~ /^\// && -x $bin ) { # we got a full path |
815
|
0
|
|
|
|
|
0
|
$log->audit( "find_bin: found $bin", %args ); |
816
|
0
|
|
|
|
|
0
|
return $bin; |
817
|
|
|
|
|
|
|
}; |
818
|
|
|
|
|
|
|
|
819
|
26
|
|
|
|
|
45
|
my @prefixes; |
820
|
26
|
50
|
|
|
|
83
|
push @prefixes, $p{dir} if $p{dir}; |
821
|
26
|
|
|
|
|
385
|
push @prefixes, qw" |
822
|
|
|
|
|
|
|
/usr/local/bin /usr/local/sbin/ /opt/local/bin /opt/local/sbin |
823
|
|
|
|
|
|
|
$prefix/mysql/bin /bin /usr/bin /sbin /usr/sbin |
824
|
|
|
|
|
|
|
"; |
825
|
26
|
|
|
|
|
200573
|
push @prefixes, cwd; |
826
|
|
|
|
|
|
|
|
827
|
26
|
|
|
|
|
385
|
my $found; |
828
|
26
|
|
|
|
|
307
|
foreach my $prefix ( @prefixes ) { |
829
|
169
|
100
|
|
|
|
4713
|
if ( -x "$prefix/$bin" ) { |
830
|
24
|
50
|
|
|
|
499
|
$found = "$prefix/$bin" and last; |
831
|
|
|
|
|
|
|
}; |
832
|
|
|
|
|
|
|
}; |
833
|
|
|
|
|
|
|
|
834
|
26
|
100
|
|
|
|
103
|
if ($found) { |
835
|
24
|
|
|
|
|
914
|
$log->audit( "find_bin: found $found", %args); |
836
|
24
|
|
|
|
|
1525
|
return $found; |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
|
839
|
2
|
|
|
|
|
99
|
return $log->error( "find_bin: could not find $bin", %args); |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
sub find_config { |
843
|
4
|
|
|
4
|
1
|
814
|
my $self = shift; |
844
|
4
|
50
|
|
|
|
36
|
my $file = shift or die "missing file name"; |
845
|
4
|
|
|
|
|
175
|
my %p = validate( @_, |
846
|
|
|
|
|
|
|
{ etcdir => { type => SCALAR | UNDEF, optional => 1, }, |
847
|
|
|
|
|
|
|
%std_opts, |
848
|
|
|
|
|
|
|
} |
849
|
|
|
|
|
|
|
); |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
#my @caller = caller; |
852
|
|
|
|
|
|
|
#warn sprintf( "find_config loaded by %s, %s, %s\n", @caller ); |
853
|
|
|
|
|
|
|
|
854
|
4
|
|
|
|
|
59
|
$log->audit("find_config: searching for $file"); |
855
|
|
|
|
|
|
|
|
856
|
4
|
|
|
|
|
8
|
my @etc_dirs; |
857
|
4
|
|
|
|
|
20
|
my $etcdir = $p{etcdir}; |
858
|
4
|
100
|
66
|
|
|
59
|
push @etc_dirs, $etcdir if ( $etcdir && -d $etcdir ); |
859
|
4
|
|
|
|
|
24
|
push @etc_dirs, qw{ /opt/local/etc /usr/local/etc /etc etc }; |
860
|
4
|
|
|
|
|
24070
|
push @etc_dirs, cwd; |
861
|
|
|
|
|
|
|
|
862
|
4
|
|
|
|
|
139
|
my $r = $self->find_readable( $file, @etc_dirs ); |
863
|
4
|
100
|
|
|
|
36
|
if ( $r ) { |
864
|
2
|
|
|
|
|
47
|
$log->audit( " found $r" ); |
865
|
2
|
|
|
|
|
135
|
return $r; |
866
|
|
|
|
|
|
|
}; |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
# try $file-dist in the working dir |
869
|
2
|
50
|
|
|
|
57
|
if ( -r "./$file-dist" ) { |
870
|
0
|
|
|
|
|
0
|
$log->audit(" found in ./"); |
871
|
0
|
|
|
|
|
0
|
return cwd . "/$file-dist"; |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
|
874
|
2
|
|
|
|
|
95
|
return $log->error( "could not find $file", fatal => $p{fatal} ); |
875
|
|
|
|
|
|
|
} |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
sub find_readable { |
878
|
16
|
|
|
16
|
0
|
42
|
my $self = shift; |
879
|
16
|
|
|
|
|
53
|
my $file = shift; |
880
|
16
|
100
|
|
|
|
98
|
my $dir = shift or return; # break recursion at end of @_ |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
#$log->audit("looking for $file in $dir") if $self->{debug}; |
883
|
14
|
100
|
|
|
|
470
|
if ( -r "$dir/$file" ) { |
884
|
3
|
|
|
3
|
|
112693
|
no warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
24903
|
|
885
|
2
|
|
|
|
|
21
|
return "$dir/$file"; # success |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
|
888
|
12
|
100
|
|
|
|
216
|
if ( ! -d $dir ) { |
889
|
5
|
|
|
|
|
55
|
return $self->find_readable( $file, @_ ); |
890
|
|
|
|
|
|
|
}; |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
# warn about directories we don't have read access to |
893
|
7
|
50
|
|
|
|
153
|
if ( ! -r $dir ) { |
894
|
0
|
|
|
|
|
0
|
$log->error( "$dir is not readable", fatal => 0 ); |
895
|
0
|
|
|
|
|
0
|
return $self->find_readable( $file, @_ ); |
896
|
|
|
|
|
|
|
}; |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
# warn about files that exist but aren't readable |
899
|
7
|
50
|
|
|
|
138
|
if ( -e "$dir/$file" ) { |
900
|
0
|
|
|
|
|
0
|
$log->error( "$dir/$file is not readable", fatal => 0); |
901
|
|
|
|
|
|
|
}; |
902
|
|
|
|
|
|
|
|
903
|
7
|
|
|
|
|
84
|
return $self->find_readable( $file, @_ ); |
904
|
|
|
|
|
|
|
} |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
sub fstab_list { |
907
|
1
|
|
|
1
|
1
|
13
|
my $self = shift; |
908
|
1
|
|
|
|
|
38
|
my %p = validate( @_, { %std_opts, } ); |
909
|
|
|
|
|
|
|
|
910
|
1
|
50
|
|
|
|
64
|
if ( $OSNAME eq "darwin" ) { |
911
|
0
|
|
|
|
|
0
|
return ['fstab not used on Darwin!']; |
912
|
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
|
|
914
|
1
|
|
|
|
|
7
|
my $fstab = "/etc/fstab"; |
915
|
1
|
50
|
|
|
|
42
|
if ( !-e $fstab ) { |
916
|
0
|
0
|
|
|
|
0
|
print "fstab_list: FAILURE: $fstab does not exist!\n" if $p{debug}; |
917
|
0
|
|
|
|
|
0
|
return; |
918
|
|
|
|
|
|
|
} |
919
|
|
|
|
|
|
|
|
920
|
1
|
|
|
|
|
239
|
my $grep = $self->find_bin( "grep", debug => 0 ); |
921
|
1
|
|
|
|
|
10718
|
my @fstabs = `$grep -v cdr $fstab`; |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
# foreach my $fstab (@fstabs) |
924
|
|
|
|
|
|
|
# {} |
925
|
|
|
|
|
|
|
# my @fields = split(/ /, $fstab); |
926
|
|
|
|
|
|
|
# #print "device: $fields[0] mount: $fields[1]\n"; |
927
|
|
|
|
|
|
|
# {}; |
928
|
|
|
|
|
|
|
# print "\n\n END of fstabs\n\n"; |
929
|
|
|
|
|
|
|
|
930
|
1
|
|
|
|
|
469
|
return \@fstabs; |
931
|
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
sub get_cpan_config { |
934
|
|
|
|
|
|
|
|
935
|
0
|
|
|
0
|
0
|
0
|
my $ftp = `which ftp`; chomp $ftp; |
|
0
|
|
|
|
|
0
|
|
936
|
0
|
|
|
|
|
0
|
my $gzip = `which gzip`; chomp $gzip; |
|
0
|
|
|
|
|
0
|
|
937
|
0
|
|
|
|
|
0
|
my $unzip = `which unzip`; chomp $unzip; |
|
0
|
|
|
|
|
0
|
|
938
|
0
|
|
|
|
|
0
|
my $tar = `which tar`; chomp $tar; |
|
0
|
|
|
|
|
0
|
|
939
|
0
|
|
|
|
|
0
|
my $make = `which make`; chomp $make; |
|
0
|
|
|
|
|
0
|
|
940
|
0
|
|
|
|
|
0
|
my $wget = `which wget`; chomp $wget; |
|
0
|
|
|
|
|
0
|
|
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
return |
943
|
|
|
|
|
|
|
{ |
944
|
0
|
|
|
|
|
0
|
'build_cache' => q[10], |
945
|
|
|
|
|
|
|
'build_dir' => qq[$ENV{HOME}/.cpan/build], |
946
|
|
|
|
|
|
|
'cache_metadata' => q[1], |
947
|
|
|
|
|
|
|
'cpan_home' => qq[$ENV{HOME}/.cpan], |
948
|
|
|
|
|
|
|
'ftp' => $ftp, |
949
|
|
|
|
|
|
|
'ftp_proxy' => q[], |
950
|
|
|
|
|
|
|
'getcwd' => q[cwd], |
951
|
|
|
|
|
|
|
'gpg' => q[], |
952
|
|
|
|
|
|
|
'gzip' => $gzip, |
953
|
|
|
|
|
|
|
'histfile' => qq[$ENV{HOME}/.cpan/histfile], |
954
|
|
|
|
|
|
|
'histsize' => q[100], |
955
|
|
|
|
|
|
|
'http_proxy' => q[], |
956
|
|
|
|
|
|
|
'inactivity_timeout' => q[5], |
957
|
|
|
|
|
|
|
'index_expire' => q[1], |
958
|
|
|
|
|
|
|
'inhibit_startup_message' => q[1], |
959
|
|
|
|
|
|
|
'keep_source_where' => qq[$ENV{HOME}/.cpan/sources], |
960
|
|
|
|
|
|
|
'lynx' => q[], |
961
|
|
|
|
|
|
|
'make' => $make, |
962
|
|
|
|
|
|
|
'make_arg' => q[], |
963
|
|
|
|
|
|
|
'make_install_arg' => q[], |
964
|
|
|
|
|
|
|
'makepl_arg' => q[], |
965
|
|
|
|
|
|
|
'ncftp' => q[], |
966
|
|
|
|
|
|
|
'ncftpget' => q[], |
967
|
|
|
|
|
|
|
'no_proxy' => q[], |
968
|
|
|
|
|
|
|
'pager' => q[less], |
969
|
|
|
|
|
|
|
'prerequisites_policy' => q[follow], |
970
|
|
|
|
|
|
|
'scan_cache' => q[atstart], |
971
|
|
|
|
|
|
|
'shell' => q[/bin/csh], |
972
|
|
|
|
|
|
|
'tar' => $tar, |
973
|
|
|
|
|
|
|
'term_is_latin' => q[1], |
974
|
|
|
|
|
|
|
'unzip' => $unzip, |
975
|
|
|
|
|
|
|
'urllist' => [ 'http://www.perl.com/CPAN/', 'ftp://cpan.cs.utah.edu/pub/CPAN/', 'ftp://mirrors.kernel.org/pub/CPAN', 'ftp://osl.uoregon.edu/CPAN/', 'http://cpan.yahoo.com/' ], |
976
|
|
|
|
|
|
|
'wget' => $wget, |
977
|
|
|
|
|
|
|
}; |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
} |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
sub get_dir_files { |
982
|
4
|
|
|
4
|
1
|
1661
|
my $self = shift; |
983
|
4
|
50
|
|
|
|
59
|
my $dir = shift or die "missing dir name"; |
984
|
4
|
|
|
|
|
302
|
my %p = validate( @_, { %std_opts } ); |
985
|
|
|
|
|
|
|
|
986
|
4
|
|
|
|
|
81
|
my %args = $self->get_std_args( %p ); |
987
|
|
|
|
|
|
|
|
988
|
4
|
|
|
|
|
28
|
my @files; |
989
|
|
|
|
|
|
|
|
990
|
4
|
50
|
|
|
|
163
|
return $log->error( "dir $dir is not a directory!", %args) |
991
|
|
|
|
|
|
|
if ! -d $dir; |
992
|
|
|
|
|
|
|
|
993
|
4
|
50
|
|
|
|
218
|
opendir D, $dir or return $log->error( "couldn't open $dir: $!", %args ); |
994
|
|
|
|
|
|
|
|
995
|
4
|
|
|
|
|
511
|
while ( defined( my $f = readdir(D) ) ) { |
996
|
147
|
100
|
|
|
|
927
|
next if $f =~ /^\.\.?$/; |
997
|
139
|
|
|
|
|
1442
|
push @files, "$dir/$f"; |
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
|
1000
|
4
|
|
|
|
|
99
|
closedir(D); |
1001
|
|
|
|
|
|
|
|
1002
|
4
|
|
|
|
|
91
|
return @files; |
1003
|
|
|
|
|
|
|
} |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
sub get_my_ips { |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
############################################ |
1008
|
|
|
|
|
|
|
# Usage : @list_of_ips_ref = $util->get_my_ips(); |
1009
|
|
|
|
|
|
|
# Purpose : get a list of IP addresses on local interfaces |
1010
|
|
|
|
|
|
|
# Returns : an arrayref of IP addresses |
1011
|
|
|
|
|
|
|
# Parameters : only - can be one of: first, last |
1012
|
|
|
|
|
|
|
# : exclude_locahost (all 127.0 addresses) |
1013
|
|
|
|
|
|
|
# : exclude_internals (192.168, 10., 169., 172.) |
1014
|
|
|
|
|
|
|
# : exclude_ipv6 |
1015
|
|
|
|
|
|
|
# Comments : exclude options are boolean and enabled by default. |
1016
|
|
|
|
|
|
|
# tested on Mac OS X and FreeBSD |
1017
|
|
|
|
|
|
|
|
1018
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1019
|
0
|
|
|
|
|
0
|
my %p = validate( |
1020
|
|
|
|
|
|
|
@_, |
1021
|
|
|
|
|
|
|
{ 'only' => { type => SCALAR, optional => 1, default => 0 }, |
1022
|
|
|
|
|
|
|
'exclude_localhost' => |
1023
|
|
|
|
|
|
|
{ type => BOOLEAN, optional => 1, default => 1 }, |
1024
|
|
|
|
|
|
|
'exclude_internals' => |
1025
|
|
|
|
|
|
|
{ type => BOOLEAN, optional => 1, default => 1 }, |
1026
|
|
|
|
|
|
|
'exclude_ipv6' => |
1027
|
|
|
|
|
|
|
{ type => BOOLEAN, optional => 1, default => 1 }, |
1028
|
|
|
|
|
|
|
%std_opts, |
1029
|
|
|
|
|
|
|
} |
1030
|
|
|
|
|
|
|
); |
1031
|
|
|
|
|
|
|
|
1032
|
0
|
|
|
|
|
0
|
my $debug = $p{debug}; |
1033
|
0
|
|
|
|
|
0
|
my $only = $p{only}; |
1034
|
|
|
|
|
|
|
|
1035
|
0
|
|
|
|
|
0
|
my $ifconfig = $self->find_bin( "ifconfig", debug => 0 ); |
1036
|
|
|
|
|
|
|
|
1037
|
0
|
|
|
|
|
0
|
my $once = 0; |
1038
|
|
|
|
|
|
|
|
1039
|
0
|
|
|
|
|
0
|
TRY: |
1040
|
0
|
|
|
|
|
0
|
my @ips = grep {/inet/} `$ifconfig`; chomp @ips; |
|
0
|
|
|
|
|
0
|
|
1041
|
0
|
0
|
|
|
|
0
|
@ips = grep {!/inet6/} @ips if $p{exclude_ipv6}; |
|
0
|
|
|
|
|
0
|
|
1042
|
0
|
0
|
|
|
|
0
|
@ips = grep {!/inet 127\.0\.0/} @ips if $p{exclude_localhost}; |
|
0
|
|
|
|
|
0
|
|
1043
|
0
|
0
|
|
|
|
0
|
@ips = grep {!/inet (192\.168\.|10\.|172\.16\.|169\.254\.)/} @ips |
|
0
|
|
|
|
|
0
|
|
1044
|
|
|
|
|
|
|
if $p{exclude_internals}; |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# this keeps us from failing if the box has only internal IPs |
1047
|
0
|
0
|
0
|
|
|
0
|
if ( @ips < 1 || $ips[0] eq "" ) { |
1048
|
0
|
0
|
|
|
|
0
|
carp "yikes, you really don't have any public IPs?!" if $debug; |
1049
|
0
|
|
|
|
|
0
|
$p{exclude_internals} = 0; |
1050
|
0
|
|
|
|
|
0
|
$once++; |
1051
|
0
|
0
|
|
|
|
0
|
goto TRY if ( $once < 2 ); |
1052
|
|
|
|
|
|
|
} |
1053
|
|
|
|
|
|
|
|
1054
|
0
|
|
|
|
|
0
|
foreach ( @ips ) { ($_) = $_ =~ m/inet ([\d\.]+)\s/; }; |
|
0
|
|
|
|
|
0
|
|
1055
|
|
|
|
|
|
|
|
1056
|
0
|
0
|
|
|
|
0
|
return [ $ips[0] ] if $only eq 'first'; |
1057
|
0
|
0
|
|
|
|
0
|
return [ $ips[-1] ] if $only eq 'last'; |
1058
|
0
|
|
|
|
|
0
|
return \@ips; |
1059
|
|
|
|
|
|
|
} |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
sub get_std_args { |
1062
|
137
|
|
|
137
|
0
|
264
|
my $self = shift; |
1063
|
137
|
|
|
|
|
675
|
my %p = @_; |
1064
|
137
|
|
|
|
|
189
|
my %args; |
1065
|
137
|
|
|
|
|
401
|
foreach ( qw/ debug fatal test_ok quiet / ) { |
1066
|
548
|
100
|
|
|
|
1321
|
next if ! defined $p{$_}; |
1067
|
411
|
|
|
|
|
1575
|
$args{$_} = $p{$_}; |
1068
|
|
|
|
|
|
|
}; |
1069
|
137
|
|
|
|
|
1699
|
return %args; |
1070
|
|
|
|
|
|
|
}; |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
sub get_the_date { |
1073
|
15
|
|
|
15
|
1
|
79318
|
my $self = shift; |
1074
|
15
|
|
|
|
|
537
|
my %p = validate( |
1075
|
|
|
|
|
|
|
@_, |
1076
|
|
|
|
|
|
|
{ 'bump' => { type => SCALAR, optional => 1, }, |
1077
|
|
|
|
|
|
|
%std_opts |
1078
|
|
|
|
|
|
|
} |
1079
|
|
|
|
|
|
|
); |
1080
|
|
|
|
|
|
|
|
1081
|
15
|
|
100
|
|
|
190
|
my $bump = $p{bump} || 0; |
1082
|
15
|
|
|
|
|
71
|
my %args = $self->get_std_args( %p ); |
1083
|
|
|
|
|
|
|
|
1084
|
15
|
|
|
|
|
43
|
my $time = time; |
1085
|
15
|
|
|
|
|
48
|
my $mess = "get_the_date time: " . time; |
1086
|
|
|
|
|
|
|
|
1087
|
15
|
100
|
|
|
|
58
|
$bump = $bump * 86400 if $bump; |
1088
|
15
|
|
|
|
|
22
|
my $offset_time = time - $bump; |
1089
|
15
|
100
|
|
|
|
88
|
$mess .= ", (selected $offset_time)" if $time != $offset_time; |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
# load Date::Format to get the time2str function |
1092
|
15
|
|
|
|
|
31
|
eval { require Date::Format }; |
|
15
|
|
|
|
|
1434
|
|
1093
|
15
|
50
|
|
|
|
4249
|
if ( !$EVAL_ERROR ) { |
1094
|
|
|
|
|
|
|
|
1095
|
15
|
|
|
|
|
60
|
my $ss = Date::Format::time2str( "%S", ($offset_time) ); |
1096
|
15
|
|
|
|
|
1164
|
my $mn = Date::Format::time2str( "%M", ($offset_time) ); |
1097
|
15
|
|
|
|
|
658
|
my $hh = Date::Format::time2str( "%H", ($offset_time) ); |
1098
|
15
|
|
|
|
|
699
|
my $dd = Date::Format::time2str( "%d", ($offset_time) ); |
1099
|
15
|
|
|
|
|
1194
|
my $mm = Date::Format::time2str( "%m", ($offset_time) ); |
1100
|
15
|
|
|
|
|
656
|
my $yy = Date::Format::time2str( "%Y", ($offset_time) ); |
1101
|
15
|
|
|
|
|
686
|
my $lm = Date::Format::time2str( "%m", ( $offset_time - 2592000 ) ); |
1102
|
|
|
|
|
|
|
|
1103
|
15
|
|
|
|
|
722
|
$log->audit( "$mess, $yy/$mm/$dd $hh:$mn", %args); |
1104
|
15
|
|
|
|
|
195
|
return $dd, $mm, $yy, $lm, $hh, $mn, $ss; |
1105
|
|
|
|
|
|
|
} |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
# 0 1 2 3 4 5 6 7 8 |
1108
|
|
|
|
|
|
|
# ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = |
1109
|
|
|
|
|
|
|
# localtime(time); |
1110
|
|
|
|
|
|
|
# 4 = month + 1 ( see perldoc localtime) |
1111
|
|
|
|
|
|
|
# 5 = year + 1900 "" |
1112
|
|
|
|
|
|
|
|
1113
|
0
|
|
|
|
|
0
|
my @fields = localtime($offset_time); |
1114
|
|
|
|
|
|
|
|
1115
|
0
|
|
|
|
|
0
|
my $ss = sprintf( "%02i", $fields[0] ); # seconds |
1116
|
0
|
|
|
|
|
0
|
my $mn = sprintf( "%02i", $fields[1] ); # minutes |
1117
|
0
|
|
|
|
|
0
|
my $hh = sprintf( "%02i", $fields[2] ); # hours (24 hour clock) |
1118
|
|
|
|
|
|
|
|
1119
|
0
|
|
|
|
|
0
|
my $dd = sprintf( "%02i", $fields[3] ); # day of month |
1120
|
0
|
|
|
|
|
0
|
my $mm = sprintf( "%02i", $fields[4] + 1 ); # month |
1121
|
0
|
|
|
|
|
0
|
my $yy = ( $fields[5] + 1900 ); # year |
1122
|
|
|
|
|
|
|
|
1123
|
0
|
|
|
|
|
0
|
$log->audit( "$mess, $yy/$mm/$dd $hh:$mn", %args ); |
1124
|
0
|
|
|
|
|
0
|
return $dd, $mm, $yy, undef, $hh, $mn, $ss; |
1125
|
|
|
|
|
|
|
} |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
sub get_mounted_drives { |
1128
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
1129
|
1
|
|
|
|
|
38
|
my %p = validate( @_, { %std_opts } ); |
1130
|
1
|
|
|
|
|
12
|
my %args = $log->get_std_args( %p ); |
1131
|
|
|
|
|
|
|
|
1132
|
1
|
|
|
|
|
28
|
my $mount = $self->find_bin( 'mount', %args ); |
1133
|
|
|
|
|
|
|
|
1134
|
1
|
50
|
|
|
|
41
|
-x $mount or return $log->error( "I couldn't find mount!", %args ); |
1135
|
|
|
|
|
|
|
|
1136
|
1
|
|
|
|
|
7
|
$ENV{PATH} = ""; |
1137
|
1
|
|
|
|
|
6
|
my %hash; |
1138
|
1
|
|
|
|
|
6438
|
foreach (`$mount`) { |
1139
|
17
|
|
|
|
|
203
|
my ( $d, $m ) = $_ =~ /^(.*) on (.*) \(/; |
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
#if ( $m =~ /^\// && $d =~ /^\// ) # mount drives that begin with / |
1142
|
17
|
50
|
33
|
|
|
178
|
if ( $m && $m =~ /^\// ) { # only mounts that begin with / |
1143
|
17
|
50
|
|
|
|
190
|
$log->audit( "adding: $m \t $d" ) if $p{debug}; |
1144
|
17
|
|
|
|
|
143
|
$hash{$m} = $d; |
1145
|
|
|
|
|
|
|
} |
1146
|
|
|
|
|
|
|
} |
1147
|
1
|
|
|
|
|
49
|
return \%hash; |
1148
|
|
|
|
|
|
|
} |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
sub get_url { |
1151
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1152
|
0
|
|
|
|
|
0
|
my $url = shift; |
1153
|
0
|
|
|
|
|
0
|
my %p = validate( |
1154
|
|
|
|
|
|
|
@_, |
1155
|
|
|
|
|
|
|
{ dir => { type => SCALAR, optional => 1 }, |
1156
|
|
|
|
|
|
|
timeout => { type => SCALAR, optional => 1 }, |
1157
|
|
|
|
|
|
|
%std_opts, |
1158
|
|
|
|
|
|
|
} |
1159
|
|
|
|
|
|
|
); |
1160
|
|
|
|
|
|
|
|
1161
|
0
|
|
|
|
|
0
|
my $dir = $p{dir}; |
1162
|
0
|
|
|
|
|
0
|
my %args = $log->get_std_args( %p ); |
1163
|
|
|
|
|
|
|
|
1164
|
0
|
|
|
|
|
0
|
my ($ua, $response); |
1165
|
|
|
|
|
|
|
## no critic ( ProhibitStringyEval ) |
1166
|
0
|
|
|
|
|
0
|
eval "require LWP::Simple"; |
1167
|
|
|
|
|
|
|
## use critic |
1168
|
0
|
0
|
|
|
|
0
|
return $self->get_url_system( $url, %p ) if $EVAL_ERROR; |
1169
|
|
|
|
|
|
|
|
1170
|
0
|
|
|
|
|
0
|
my $uri = URI->new($url); |
1171
|
0
|
|
|
|
|
0
|
my @parts = $uri->path_segments; |
1172
|
0
|
|
|
|
|
0
|
my $file = $parts[-1]; # everything after the last / in the URL |
1173
|
0
|
|
|
|
|
0
|
my $file_path = $file; |
1174
|
0
|
0
|
|
|
|
0
|
$file_path = "$dir/$file" if $dir; |
1175
|
|
|
|
|
|
|
|
1176
|
0
|
|
|
|
|
0
|
$log->audit( "fetching $url" ); |
1177
|
0
|
|
|
|
|
0
|
eval { $response = LWP::Simple::mirror($url, $file_path ); }; |
|
0
|
|
|
|
|
0
|
|
1178
|
|
|
|
|
|
|
|
1179
|
0
|
0
|
|
|
|
0
|
if ( $response ) { |
1180
|
0
|
0
|
|
|
|
0
|
if ( $response == 404 ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1181
|
0
|
|
|
|
|
0
|
return $log->error( "file not found ($url)", %args ); |
1182
|
|
|
|
|
|
|
} |
1183
|
|
|
|
|
|
|
elsif ($response == 304 ) { |
1184
|
0
|
|
|
|
|
0
|
$log->audit( "result 304: file is up-to-date" ); |
1185
|
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
|
elsif ( $response == 200 ) { |
1187
|
0
|
|
|
|
|
0
|
$log->audit( "result 200: file download ok" ); |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
else { |
1190
|
0
|
|
|
|
|
0
|
$log->error( "unhandled response: $response", fatal => 0 ); |
1191
|
|
|
|
|
|
|
}; |
1192
|
|
|
|
|
|
|
}; |
1193
|
|
|
|
|
|
|
|
1194
|
0
|
0
|
|
|
|
0
|
return if ! -e $file_path; |
1195
|
0
|
|
|
|
|
0
|
return $response; |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
sub get_url_system { |
1199
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1200
|
0
|
|
|
|
|
0
|
my $url = shift; |
1201
|
0
|
|
|
|
|
0
|
my %p = validate( |
1202
|
|
|
|
|
|
|
@_, |
1203
|
|
|
|
|
|
|
{ dir => { type => SCALAR, optional => 1 }, |
1204
|
|
|
|
|
|
|
timeout => { type => SCALAR, optional => 1, }, |
1205
|
|
|
|
|
|
|
%std_opts, |
1206
|
|
|
|
|
|
|
} |
1207
|
|
|
|
|
|
|
); |
1208
|
|
|
|
|
|
|
|
1209
|
0
|
|
|
|
|
0
|
my $dir = $p{dir}; |
1210
|
0
|
|
|
|
|
0
|
my $debug = $p{debug}; |
1211
|
0
|
|
|
|
|
0
|
my %args = $log->get_std_args( %p ); |
1212
|
|
|
|
|
|
|
|
1213
|
0
|
|
|
|
|
0
|
my ($fetchbin, $found); |
1214
|
0
|
0
|
|
|
|
0
|
if ( $OSNAME eq "freebsd" ) { |
|
|
0
|
|
|
|
|
|
1215
|
0
|
|
|
|
|
0
|
$fetchbin = $self->find_bin( 'fetch', %args); |
1216
|
0
|
0
|
0
|
|
|
0
|
if ( $fetchbin && -x $fetchbin ) { |
1217
|
0
|
|
|
|
|
0
|
$found = $fetchbin; |
1218
|
0
|
0
|
|
|
|
0
|
$found .= " -q" if !$debug; |
1219
|
|
|
|
|
|
|
} |
1220
|
|
|
|
|
|
|
} |
1221
|
|
|
|
|
|
|
elsif ( $OSNAME eq "darwin" ) { |
1222
|
0
|
|
|
|
|
0
|
$fetchbin = $self->find_bin( 'curl', %args ); |
1223
|
0
|
0
|
0
|
|
|
0
|
if ( $fetchbin && -x $fetchbin ) { |
1224
|
0
|
|
|
|
|
0
|
$found = "$fetchbin -O"; |
1225
|
0
|
0
|
|
|
|
0
|
$found .= " -s " if !$debug; |
1226
|
|
|
|
|
|
|
} |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
|
1229
|
0
|
0
|
|
|
|
0
|
if ( !$found ) { |
1230
|
0
|
|
|
|
|
0
|
$fetchbin = $self->find_bin( 'wget', %args); |
1231
|
0
|
0
|
0
|
|
|
0
|
$found = $fetchbin if $fetchbin && -x $fetchbin; |
1232
|
|
|
|
|
|
|
} |
1233
|
|
|
|
|
|
|
|
1234
|
0
|
0
|
|
|
|
0
|
return $log->error( "Failed to fetch $url.\n\tCouldn't find wget. Please install it.", %args ) |
1235
|
|
|
|
|
|
|
if !$found; |
1236
|
|
|
|
|
|
|
|
1237
|
0
|
|
|
|
|
0
|
my $fetchcmd = "$found $url"; |
1238
|
|
|
|
|
|
|
|
1239
|
0
|
|
0
|
|
|
0
|
my $timeout = $p{timeout} || 0; |
1240
|
0
|
0
|
|
|
|
0
|
if ( ! $timeout ) { |
1241
|
0
|
0
|
|
|
|
0
|
$self->syscmd( $fetchcmd, %args ) or return; |
1242
|
0
|
|
|
|
|
0
|
my $uri = URI->new($url); |
1243
|
0
|
|
|
|
|
0
|
my @parts = $uri->path_segments; |
1244
|
0
|
|
|
|
|
0
|
my $file = $parts[-1]; # everything after the last / in the URL |
1245
|
0
|
0
|
0
|
|
|
0
|
if ( -e $file && $dir && -d $dir ) { |
|
|
|
0
|
|
|
|
|
1246
|
0
|
|
|
|
|
0
|
$log->audit("moving file $file to $dir" ); |
1247
|
0
|
|
|
|
|
0
|
move $file, "$dir/$file"; |
1248
|
0
|
|
|
|
|
0
|
return 1; |
1249
|
|
|
|
|
|
|
}; |
1250
|
|
|
|
|
|
|
}; |
1251
|
|
|
|
|
|
|
|
1252
|
0
|
|
|
|
|
0
|
my $r; |
1253
|
0
|
|
|
|
|
0
|
eval { |
1254
|
0
|
|
|
0
|
|
0
|
local $SIG{ALRM} = sub { die "alarm\n" }; |
|
0
|
|
|
|
|
0
|
|
1255
|
0
|
|
|
|
|
0
|
alarm $timeout; |
1256
|
0
|
|
|
|
|
0
|
$r = $self->syscmd( $fetchcmd, %args ); |
1257
|
0
|
|
|
|
|
0
|
alarm 0; |
1258
|
|
|
|
|
|
|
}; |
1259
|
|
|
|
|
|
|
|
1260
|
0
|
0
|
|
|
|
0
|
if ($EVAL_ERROR) { # propagate unexpected errors |
1261
|
0
|
0
|
|
|
|
0
|
print "timed out!\n" if $EVAL_ERROR eq "alarm\n"; |
1262
|
0
|
|
|
|
|
0
|
return $log->error( $EVAL_ERROR, %args ); |
1263
|
|
|
|
|
|
|
} |
1264
|
|
|
|
|
|
|
|
1265
|
0
|
0
|
|
|
|
0
|
return $log->error( "error executing $fetchcmd", %args) if !$r; |
1266
|
0
|
|
|
|
|
0
|
return 1; |
1267
|
|
|
|
|
|
|
} |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
sub has_module { |
1270
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1271
|
0
|
|
|
|
|
0
|
my ($name, $ver) = @_; |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
## no critic ( ProhibitStringyEval ) |
1274
|
0
|
0
|
|
|
|
0
|
eval "use $name" . ($ver ? " $ver;" : ";"); |
1275
|
|
|
|
|
|
|
## use critic |
1276
|
|
|
|
|
|
|
|
1277
|
0
|
|
|
|
|
0
|
!$EVAL_ERROR; |
1278
|
|
|
|
|
|
|
}; |
1279
|
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
sub install_if_changed { |
1281
|
1
|
|
|
1
|
0
|
24
|
my $self = shift; |
1282
|
1
|
|
|
|
|
696
|
my %p = validate( |
1283
|
|
|
|
|
|
|
@_, |
1284
|
|
|
|
|
|
|
{ newfile => { type => SCALAR, optional => 0, }, |
1285
|
|
|
|
|
|
|
existing=> { type => SCALAR, optional => 0, }, |
1286
|
|
|
|
|
|
|
mode => { type => SCALAR, optional => 1, }, |
1287
|
|
|
|
|
|
|
uid => { type => SCALAR, optional => 1, }, |
1288
|
|
|
|
|
|
|
gid => { type => SCALAR, optional => 1, }, |
1289
|
|
|
|
|
|
|
sudo => { type => BOOLEAN, optional => 1, default => 0 }, |
1290
|
|
|
|
|
|
|
notify => { type => BOOLEAN, optional => 1, }, |
1291
|
|
|
|
|
|
|
email => { type => SCALAR, optional => 1, default => 'postmaster' }, |
1292
|
|
|
|
|
|
|
clean => { type => BOOLEAN, optional => 1, default => 1 }, |
1293
|
|
|
|
|
|
|
archive => { type => BOOLEAN, optional => 1, default => 0 }, |
1294
|
|
|
|
|
|
|
%std_opts, |
1295
|
|
|
|
|
|
|
}, |
1296
|
|
|
|
|
|
|
); |
1297
|
|
|
|
|
|
|
|
1298
|
1
|
|
|
|
|
92
|
my ( $newfile, $existing, $mode, $uid, $gid, $email) = ( |
1299
|
|
|
|
|
|
|
$p{newfile}, $p{existing}, $p{mode}, $p{uid}, $p{gid}, $p{email} ); |
1300
|
1
|
|
|
|
|
54
|
my ($sudo, $notify ) = ($p{sudo}, $p{notify} ); |
1301
|
1
|
|
|
|
|
15
|
my %args = $self->get_std_args( %p ); |
1302
|
|
|
|
|
|
|
|
1303
|
1
|
50
|
|
|
|
30
|
if ( $newfile !~ /\// ) { |
1304
|
|
|
|
|
|
|
# relative filename given |
1305
|
0
|
|
|
|
|
0
|
$log->audit( "relative filename given, use complete paths " |
1306
|
|
|
|
|
|
|
. "for more predicatable results!\n" |
1307
|
|
|
|
|
|
|
. "working directory is " . cwd() ); |
1308
|
|
|
|
|
|
|
} |
1309
|
|
|
|
|
|
|
|
1310
|
1
|
50
|
|
|
|
41
|
return $log->error( "file ($newfile) does not exist", %args ) |
1311
|
|
|
|
|
|
|
if !-e $newfile; |
1312
|
|
|
|
|
|
|
|
1313
|
1
|
50
|
|
|
|
35
|
return $log->error( "file ($newfile) is not a file", %args ) |
1314
|
|
|
|
|
|
|
if !-f $newfile; |
1315
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
# make sure existing and new are writable |
1317
|
1
|
50
|
33
|
|
|
17
|
if ( !$self->is_writable( $existing, fatal => 0 ) |
1318
|
|
|
|
|
|
|
|| !$self->is_writable( $newfile, fatal => 0 ) ) { |
1319
|
|
|
|
|
|
|
|
1320
|
|
|
|
|
|
|
# root does not have permission, sudo won't do any good |
1321
|
0
|
0
|
|
|
|
0
|
return $log->error("no write permission", %args) if $UID == 0; |
1322
|
|
|
|
|
|
|
|
1323
|
0
|
0
|
|
|
|
0
|
if ( $sudo ) { |
1324
|
0
|
0
|
|
|
|
0
|
$sudo = $self->find_bin( 'sudo', %args ) or |
1325
|
|
|
|
|
|
|
return $log->error( "you are not root, sudo was not found, and you don't have permission to write to $newfile or $existing" ); |
1326
|
|
|
|
|
|
|
} |
1327
|
|
|
|
|
|
|
} |
1328
|
|
|
|
|
|
|
|
1329
|
1
|
|
|
|
|
11
|
my $diffie; |
1330
|
1
|
50
|
|
|
|
36
|
if ( -f $existing ) { |
1331
|
|
|
|
|
|
|
$diffie = $self->files_diff( %args, |
1332
|
|
|
|
|
|
|
f1 => $newfile, |
1333
|
|
|
|
|
|
|
f2 => $existing, |
1334
|
|
|
|
|
|
|
type => "text", |
1335
|
1
|
50
|
|
|
|
156
|
) or do { |
1336
|
1
|
|
|
|
|
138
|
$log->audit( "$existing is already up-to-date.", %args); |
1337
|
1
|
50
|
|
|
|
17
|
unlink $newfile if $p{clean}; |
1338
|
1
|
|
|
|
|
89
|
return 2; |
1339
|
|
|
|
|
|
|
}; |
1340
|
|
|
|
|
|
|
}; |
1341
|
|
|
|
|
|
|
|
1342
|
0
|
|
|
|
|
0
|
$log->audit("checking $existing", %args); |
1343
|
|
|
|
|
|
|
|
1344
|
0
|
0
|
0
|
|
|
0
|
$self->chown( $newfile, |
1345
|
|
|
|
|
|
|
uid => $uid, |
1346
|
|
|
|
|
|
|
gid => $gid, |
1347
|
|
|
|
|
|
|
sudo => $sudo, |
1348
|
|
|
|
|
|
|
%args |
1349
|
|
|
|
|
|
|
) |
1350
|
|
|
|
|
|
|
if ( $uid && $gid ); # set file ownership on the new file |
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
# set file permissions on the new file |
1353
|
0
|
0
|
0
|
|
|
0
|
$self->chmod( |
1354
|
|
|
|
|
|
|
file_or_dir => $existing, |
1355
|
|
|
|
|
|
|
mode => $mode, |
1356
|
|
|
|
|
|
|
sudo => $sudo, |
1357
|
|
|
|
|
|
|
%args |
1358
|
|
|
|
|
|
|
) |
1359
|
|
|
|
|
|
|
if ( -e $existing && $mode ); |
1360
|
|
|
|
|
|
|
|
1361
|
0
|
|
|
|
|
0
|
$self->install_if_changed_notify( $notify, $email, $existing, $diffie); |
1362
|
0
|
0
|
0
|
|
|
0
|
$self->archive_file( $existing, %args) if ( -e $existing && $p{archive} ); |
1363
|
0
|
|
|
|
|
0
|
$self->install_if_changed_copy( $sudo, $newfile, $existing, $p{clean}, \%args ); |
1364
|
|
|
|
|
|
|
|
1365
|
0
|
0
|
0
|
|
|
0
|
$self->chown( $existing, |
1366
|
|
|
|
|
|
|
uid => $uid, |
1367
|
|
|
|
|
|
|
gid => $gid, |
1368
|
|
|
|
|
|
|
sudo => $sudo, |
1369
|
|
|
|
|
|
|
%args |
1370
|
|
|
|
|
|
|
) if ( $uid && $gid ); # set ownership on new existing file |
1371
|
|
|
|
|
|
|
|
1372
|
0
|
0
|
|
|
|
0
|
$self->chmod( |
1373
|
|
|
|
|
|
|
file_or_dir => $existing, |
1374
|
|
|
|
|
|
|
mode => $mode, |
1375
|
|
|
|
|
|
|
sudo => $sudo, |
1376
|
|
|
|
|
|
|
%args |
1377
|
|
|
|
|
|
|
) |
1378
|
|
|
|
|
|
|
if $mode; # set file permissions (paranoid) |
1379
|
|
|
|
|
|
|
|
1380
|
0
|
|
|
|
|
0
|
$log->audit( " updated $existing" ); |
1381
|
0
|
|
|
|
|
0
|
return 1; |
1382
|
|
|
|
|
|
|
} |
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
sub install_if_changed_copy { |
1385
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1386
|
0
|
|
|
|
|
0
|
my ( $sudo, $newfile, $existing, $clean, $args ) = @_; |
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
# install the new file |
1389
|
0
|
0
|
|
|
|
0
|
if ($sudo) { |
1390
|
0
|
|
|
|
|
0
|
my $cp = $self->find_bin( 'cp', %$args ); |
1391
|
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
|
# back up the existing file |
1393
|
0
|
0
|
|
|
|
0
|
$self->syscmd( "$sudo $cp $existing $existing.bak", %$args) |
1394
|
|
|
|
|
|
|
if -e $existing; |
1395
|
|
|
|
|
|
|
|
1396
|
|
|
|
|
|
|
# install the new one |
1397
|
0
|
0
|
|
|
|
0
|
if ( $clean ) { |
1398
|
0
|
|
|
|
|
0
|
my $mv = $self->find_bin( 'mv' ); |
1399
|
0
|
|
|
|
|
0
|
$self->syscmd( "$sudo $mv $newfile $existing", %$args); |
1400
|
|
|
|
|
|
|
} |
1401
|
|
|
|
|
|
|
else { |
1402
|
0
|
|
|
|
|
0
|
$self->syscmd( "$sudo $cp $newfile $existing",%$args); |
1403
|
|
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
} |
1405
|
|
|
|
|
|
|
else { |
1406
|
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
|
# back up the existing file |
1408
|
0
|
0
|
|
|
|
0
|
copy( $existing, "$existing.bak" ) if -e $existing; |
1409
|
|
|
|
|
|
|
|
1410
|
0
|
0
|
|
|
|
0
|
if ( $clean ) { |
1411
|
0
|
0
|
|
|
|
0
|
move( $newfile, $existing ) or |
1412
|
|
|
|
|
|
|
return $log->error( "failed copy $newfile to $existing", %$args); |
1413
|
|
|
|
|
|
|
} |
1414
|
|
|
|
|
|
|
else { |
1415
|
0
|
0
|
|
|
|
0
|
copy( $newfile, $existing ) or |
1416
|
|
|
|
|
|
|
return $log->error( "failed copy $newfile to $existing", %$args ); |
1417
|
|
|
|
|
|
|
} |
1418
|
|
|
|
|
|
|
} |
1419
|
|
|
|
|
|
|
}; |
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
sub install_if_changed_notify { |
1422
|
|
|
|
|
|
|
|
1423
|
0
|
|
|
0
|
0
|
0
|
my ($self, $notify, $email, $existing, $diffie) = @_; |
1424
|
|
|
|
|
|
|
|
1425
|
0
|
0
|
|
|
|
0
|
return if ! $notify; |
1426
|
0
|
0
|
|
|
|
0
|
return if ! -f $existing; |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
# email diffs to admin |
1429
|
|
|
|
|
|
|
|
1430
|
0
|
|
|
|
|
0
|
eval { require Mail::Send; }; |
|
0
|
|
|
|
|
0
|
|
1431
|
|
|
|
|
|
|
|
1432
|
0
|
0
|
|
|
|
0
|
return $log->error( "could not send notice, Mail::Send is not installed!", fatal => 0) |
1433
|
|
|
|
|
|
|
if $EVAL_ERROR; |
1434
|
|
|
|
|
|
|
|
1435
|
0
|
|
|
|
|
0
|
my $msg = Mail::Send->new; |
1436
|
0
|
|
|
|
|
0
|
$msg->subject("$existing updated by $0"); |
1437
|
0
|
|
|
|
|
0
|
$msg->to($email); |
1438
|
0
|
|
|
|
|
0
|
my $email_message = $msg->open; |
1439
|
|
|
|
|
|
|
|
1440
|
0
|
|
|
|
|
0
|
print $email_message "This message is to notify you that $existing has been altered. The difference between the new file and the old one is:\n\n$diffie"; |
1441
|
|
|
|
|
|
|
|
1442
|
0
|
|
|
|
|
0
|
$email_message->close; |
1443
|
|
|
|
|
|
|
}; |
1444
|
|
|
|
|
|
|
|
1445
|
|
|
|
|
|
|
sub install_from_source { |
1446
|
2
|
|
|
2
|
1
|
9
|
my $self = shift; |
1447
|
2
|
|
|
|
|
245
|
my %p = validate( |
1448
|
|
|
|
|
|
|
@_, |
1449
|
|
|
|
|
|
|
{ 'site' => { type => SCALAR, optional => 0, }, |
1450
|
|
|
|
|
|
|
'url' => { type => SCALAR, optional => 0, }, |
1451
|
|
|
|
|
|
|
'package' => { type => SCALAR, optional => 0, }, |
1452
|
|
|
|
|
|
|
'targets' => { type => ARRAYREF, optional => 1, }, |
1453
|
|
|
|
|
|
|
'patches' => { type => ARRAYREF, optional => 1, }, |
1454
|
|
|
|
|
|
|
'patch_url' => { type => SCALAR, optional => 1, }, |
1455
|
|
|
|
|
|
|
'patch_args' => { type => SCALAR, optional => 1, }, |
1456
|
|
|
|
|
|
|
'source_dir' => { type => SCALAR, optional => 1, }, |
1457
|
|
|
|
|
|
|
'source_sub_dir' => { type => SCALAR, optional => 1, }, |
1458
|
|
|
|
|
|
|
'bintest' => { type => SCALAR, optional => 1, }, |
1459
|
|
|
|
|
|
|
%std_opts, |
1460
|
|
|
|
|
|
|
}, |
1461
|
|
|
|
|
|
|
); |
1462
|
|
|
|
|
|
|
|
1463
|
2
|
50
|
|
|
|
77
|
return $p{test_ok} if defined $p{test_ok}; |
1464
|
0
|
|
|
|
|
0
|
my %args = $self->get_std_args( %p ); |
1465
|
|
|
|
|
|
|
|
1466
|
0
|
|
|
|
|
0
|
my ( $site, $url, $package, $targets, $patches, $bintest ) = |
1467
|
|
|
|
|
|
|
( $p{site}, $p{url}, $p{package}, |
1468
|
|
|
|
|
|
|
$p{targets}, $p{patches}, $p{bintest} ); |
1469
|
|
|
|
|
|
|
|
1470
|
0
|
|
0
|
|
|
0
|
my $patch_args = $p{patch_args} || ''; |
1471
|
0
|
|
0
|
|
|
0
|
my $src = $p{source_dir} || "/usr/local/src"; |
1472
|
0
|
0
|
|
|
|
0
|
$src .= "/$p{source_sub_dir}" if $p{source_sub_dir}; |
1473
|
|
|
|
|
|
|
|
1474
|
0
|
|
|
|
|
0
|
my $original_directory = cwd; |
1475
|
|
|
|
|
|
|
|
1476
|
0
|
|
|
|
|
0
|
$self->cwd_source_dir( $src, %args ); |
1477
|
|
|
|
|
|
|
|
1478
|
0
|
0
|
0
|
|
|
0
|
if ( $bintest && $self->find_bin( $bintest, fatal => 0, debug => 0 ) ) { |
1479
|
0
|
0
|
|
|
|
0
|
return if ! $self->yes_or_no( |
1480
|
|
|
|
|
|
|
"$bintest exists, suggesting that " |
1481
|
|
|
|
|
|
|
. "$package is installed. Do you want to reinstall?", |
1482
|
|
|
|
|
|
|
timeout => 60, |
1483
|
|
|
|
|
|
|
); |
1484
|
|
|
|
|
|
|
} |
1485
|
|
|
|
|
|
|
|
1486
|
0
|
|
|
|
|
0
|
$log->audit( "install_from_source: building $package in $src"); |
1487
|
|
|
|
|
|
|
|
1488
|
0
|
0
|
|
|
|
0
|
$self->install_from_source_cleanup($package,$src) or return; |
1489
|
0
|
0
|
|
|
|
0
|
$self->install_from_source_get_files($package,$site,$url,$p{patch_url},$patches) or return; |
1490
|
|
|
|
|
|
|
|
1491
|
0
|
0
|
|
|
|
0
|
$self->extract_archive( $package ) |
1492
|
|
|
|
|
|
|
or return $log->error( "Couldn't expand $package: $!", %args ); |
1493
|
|
|
|
|
|
|
|
1494
|
|
|
|
|
|
|
# cd into the package directory |
1495
|
0
|
|
|
|
|
0
|
my $sub_path; |
1496
|
0
|
0
|
|
|
|
0
|
if ( -d $package ) { |
1497
|
0
|
0
|
|
|
|
0
|
chdir $package or |
1498
|
|
|
|
|
|
|
return $log->error( "FAILED to chdir $package!", %args ); |
1499
|
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
else { |
1501
|
|
|
|
|
|
|
|
1502
|
|
|
|
|
|
|
# some packages (like daemontools) unpack within an enclosing directory |
1503
|
0
|
|
|
|
|
0
|
$sub_path = `find ./ -name $package`; # tainted data |
1504
|
0
|
|
|
|
|
0
|
chomp $sub_path; |
1505
|
0
|
|
|
|
|
0
|
($sub_path) = $sub_path =~ /^([-\w\/.]+)$/; # untaint it |
1506
|
|
|
|
|
|
|
|
1507
|
0
|
0
|
|
|
|
0
|
$log->audit( "found sources in $sub_path" ) if $sub_path; |
1508
|
0
|
0
|
0
|
|
|
0
|
return $log->error( "FAILED to find $package sources!",fatal=>0) |
1509
|
|
|
|
|
|
|
unless ( -d $sub_path && chdir($sub_path) ); |
1510
|
|
|
|
|
|
|
} |
1511
|
|
|
|
|
|
|
|
1512
|
0
|
0
|
|
|
|
0
|
$self->install_from_source_apply_patches($src, $patches, $patch_args) or return; |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
# set default build targets if none are provided |
1515
|
0
|
0
|
|
|
|
0
|
if ( !@$targets[0] ) { |
1516
|
0
|
|
|
|
|
0
|
$log->audit( "\tusing default targets (./configure, make, make install)" ); |
1517
|
0
|
|
|
|
|
0
|
@$targets = ( "./configure", "make", "make install" ); |
1518
|
|
|
|
|
|
|
} |
1519
|
|
|
|
|
|
|
|
1520
|
0
|
|
|
|
|
0
|
my $msg = "install_from_source: using targets\n"; |
1521
|
0
|
|
|
|
|
0
|
foreach (@$targets) { $msg .= "\t$_\n" }; |
|
0
|
|
|
|
|
0
|
|
1522
|
0
|
0
|
|
|
|
0
|
$log->audit( $msg ) if $p{debug}; |
1523
|
|
|
|
|
|
|
|
1524
|
|
|
|
|
|
|
# build the program |
1525
|
0
|
|
|
|
|
0
|
foreach my $target (@$targets) { |
1526
|
|
|
|
|
|
|
|
1527
|
0
|
0
|
|
|
|
0
|
if ( $target =~ /^cd (.*)$/ ) { |
1528
|
0
|
|
|
|
|
0
|
$log->audit( "cwd: " . cwd . " -> " . $1 ); |
1529
|
0
|
0
|
|
|
|
0
|
chdir($1) or return $log->error( "couldn't chdir $1: $!", %args); |
1530
|
0
|
|
|
|
|
0
|
next; |
1531
|
|
|
|
|
|
|
} |
1532
|
|
|
|
|
|
|
|
1533
|
0
|
0
|
|
|
|
0
|
$self->syscmd( $target, %args ) or |
1534
|
|
|
|
|
|
|
return $log->error( "pwd: " . cwd . "\n$target failed: $!", %args ); |
1535
|
|
|
|
|
|
|
} |
1536
|
|
|
|
|
|
|
|
1537
|
|
|
|
|
|
|
# clean up the build sources |
1538
|
0
|
|
|
|
|
0
|
chdir $src; |
1539
|
0
|
0
|
|
|
|
0
|
$self->syscmd( "rm -rf $package", %args ) if -d $package; |
1540
|
|
|
|
|
|
|
|
1541
|
0
|
0
|
0
|
|
|
0
|
$self->syscmd( "rm -rf $package/$sub_path", %args ) |
1542
|
|
|
|
|
|
|
if defined $sub_path && -d "$package/$sub_path"; |
1543
|
|
|
|
|
|
|
|
1544
|
0
|
|
|
|
|
0
|
chdir $original_directory; |
1545
|
0
|
|
|
|
|
0
|
return 1; |
1546
|
|
|
|
|
|
|
} |
1547
|
|
|
|
|
|
|
|
1548
|
|
|
|
|
|
|
sub install_from_source_apply_patches { |
1549
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1550
|
0
|
|
|
|
|
0
|
my ($src, $patches,$patch_args) = @_; |
1551
|
|
|
|
|
|
|
|
1552
|
0
|
0
|
|
|
|
0
|
return 1 if ! $patches; |
1553
|
0
|
0
|
|
|
|
0
|
return 1 if ! $patches->[0]; |
1554
|
|
|
|
|
|
|
|
1555
|
0
|
|
|
|
|
0
|
my $patchbin = $self->find_bin( "patch" ); |
1556
|
0
|
|
|
|
|
0
|
foreach my $patch (@$patches) { |
1557
|
0
|
0
|
|
|
|
0
|
$self->syscmd( "$patchbin $patch_args < $src/$patch" ) |
1558
|
|
|
|
|
|
|
or return $log->error("failed to apply patch $patch"); |
1559
|
|
|
|
|
|
|
} |
1560
|
0
|
|
|
|
|
0
|
return 1; |
1561
|
|
|
|
|
|
|
}; |
1562
|
|
|
|
|
|
|
|
1563
|
|
|
|
|
|
|
sub install_from_source_cleanup { |
1564
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1565
|
0
|
|
|
|
|
0
|
my ($package,$src) = @_; |
1566
|
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
|
# make sure there are no previous sources in the way |
1568
|
0
|
0
|
|
|
|
0
|
return 1 if ! -d $package; |
1569
|
|
|
|
|
|
|
|
1570
|
0
|
0
|
|
|
|
0
|
$self->source_warning( |
1571
|
|
|
|
|
|
|
package => $package, |
1572
|
|
|
|
|
|
|
clean => 1, |
1573
|
|
|
|
|
|
|
src => $src, |
1574
|
|
|
|
|
|
|
) or return $log->error( "OK then, skipping install.", fatal => 0); |
1575
|
|
|
|
|
|
|
|
1576
|
0
|
|
|
|
|
0
|
print "install_from_source: removing previous build sources.\n"; |
1577
|
0
|
|
|
|
|
0
|
return $self->syscmd( "rm -rf $package-*" ); |
1578
|
|
|
|
|
|
|
}; |
1579
|
|
|
|
|
|
|
|
1580
|
|
|
|
|
|
|
sub install_from_source_get_files { |
1581
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1582
|
0
|
|
|
|
|
0
|
my ($package,$site,$url,$patch_url,$patches) = @_; |
1583
|
|
|
|
|
|
|
|
1584
|
0
|
0
|
|
|
|
0
|
$self->sources_get( |
1585
|
|
|
|
|
|
|
package => $package, |
1586
|
|
|
|
|
|
|
site => $site, |
1587
|
|
|
|
|
|
|
path => $url, |
1588
|
|
|
|
|
|
|
) or return; |
1589
|
|
|
|
|
|
|
|
1590
|
0
|
0
|
0
|
|
|
0
|
if ( ! $patches || ! $patches->[0] ) { |
1591
|
0
|
|
|
|
|
0
|
$log->audit( "install_from_source: no patches to fetch." ); |
1592
|
0
|
|
|
|
|
0
|
return 1; |
1593
|
|
|
|
|
|
|
}; |
1594
|
|
|
|
|
|
|
|
1595
|
0
|
0
|
|
|
|
0
|
return $log->error( "oops! You supplied patch names to apply without a URL!") |
1596
|
|
|
|
|
|
|
if ! $patch_url; |
1597
|
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
|
|
1599
|
0
|
|
|
|
|
0
|
foreach my $patch (@$patches) { |
1600
|
0
|
0
|
|
|
|
0
|
next if ! $patch; |
1601
|
0
|
0
|
|
|
|
0
|
next if -e $patch; |
1602
|
|
|
|
|
|
|
|
1603
|
0
|
|
|
|
|
0
|
$log->audit( "install_from_source: fetching patch from $url"); |
1604
|
0
|
|
|
|
|
0
|
my $url = "$patch_url/$patch"; |
1605
|
0
|
0
|
|
|
|
0
|
$self->get_url( $url ) |
1606
|
|
|
|
|
|
|
or return $log->error( "could not fetch $url" ); |
1607
|
|
|
|
|
|
|
}; |
1608
|
|
|
|
|
|
|
|
1609
|
0
|
|
|
|
|
0
|
return 1; |
1610
|
|
|
|
|
|
|
}; |
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
sub install_package { |
1613
|
0
|
|
|
0
|
0
|
0
|
my ($self, $app, $info) = @_; |
1614
|
|
|
|
|
|
|
|
1615
|
0
|
0
|
|
|
|
0
|
if ( lc($OSNAME) eq 'freebsd' ) { |
1616
|
|
|
|
|
|
|
|
1617
|
0
|
0
|
|
|
|
0
|
my $portname = $info->{port} |
1618
|
|
|
|
|
|
|
or return $log->error( "skipping install of $app b/c port dir not set.", fatal => 0); |
1619
|
|
|
|
|
|
|
|
1620
|
0
|
0
|
|
|
|
0
|
if (`/usr/sbin/pkg_info | /usr/bin/grep $app`) { |
1621
|
0
|
|
|
|
|
0
|
print "$app is installed.\n"; |
1622
|
0
|
|
|
|
|
0
|
return 1; |
1623
|
|
|
|
|
|
|
} |
1624
|
|
|
|
|
|
|
|
1625
|
0
|
|
|
|
|
0
|
print "installing $app\n"; |
1626
|
0
|
|
|
|
|
0
|
my $portdir = glob("/usr/ports/*/$portname"); |
1627
|
|
|
|
|
|
|
|
1628
|
0
|
0
|
0
|
|
|
0
|
return $log->error( "oops, couldn't find port $app at '$portname'") |
1629
|
|
|
|
|
|
|
if ( ! -d $portdir || ! chdir $portdir ); |
1630
|
|
|
|
|
|
|
|
1631
|
0
|
0
|
|
|
|
0
|
system "make install clean" |
1632
|
|
|
|
|
|
|
and return $log->error( "'make install clean' failed for port $app", fatal => 0); |
1633
|
0
|
|
|
|
|
0
|
return 1; |
1634
|
|
|
|
|
|
|
}; |
1635
|
|
|
|
|
|
|
|
1636
|
0
|
0
|
|
|
|
0
|
if ( lc($OSNAME) eq 'linux' ) { |
1637
|
0
|
0
|
|
|
|
0
|
my $rpm = $info->{rpm} or return $log->error("skipping install of $app b/c rpm not set", fatal => 0); |
1638
|
0
|
|
|
|
|
0
|
my $yum = '/usr/bin/yum'; |
1639
|
0
|
0
|
|
|
|
0
|
return $log->error( "couldn't find yum, skipping install.", fatal => 0) |
1640
|
|
|
|
|
|
|
if ! -x $yum; |
1641
|
0
|
|
|
|
|
0
|
return system "$yum install $rpm"; |
1642
|
|
|
|
|
|
|
}; |
1643
|
|
|
|
|
|
|
|
1644
|
0
|
|
|
|
|
0
|
$log->error(" no package support for $OSNAME "); |
1645
|
|
|
|
|
|
|
} |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
sub install_module { |
1648
|
0
|
|
|
0
|
0
|
0
|
my ($self, $module, %info) = @_; |
1649
|
|
|
|
|
|
|
|
1650
|
0
|
0
|
|
|
|
0
|
my $debug = defined $info{debug} ? $info{debug} : 1; |
1651
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
## no critic ( ProhibitStringyEval ) |
1653
|
0
|
|
|
|
|
0
|
eval "use $module"; |
1654
|
|
|
|
|
|
|
## use critic |
1655
|
0
|
0
|
|
|
|
0
|
if ( ! $EVAL_ERROR ) { |
1656
|
0
|
|
|
|
|
0
|
$log->audit( "$module is already installed.",debug=>$debug ); |
1657
|
|
|
|
|
|
|
}; |
1658
|
|
|
|
|
|
|
|
1659
|
0
|
0
|
|
|
|
0
|
if ( lc($OSNAME) eq 'darwin' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1660
|
0
|
0
|
|
|
|
0
|
$self->install_module_darwin( $module ) and return 1; |
1661
|
|
|
|
|
|
|
} |
1662
|
|
|
|
|
|
|
elsif ( lc($OSNAME) eq 'freebsd' ) { |
1663
|
0
|
0
|
|
|
|
0
|
$self->install_module_freebsd( $module, \%info) and return 1; |
1664
|
|
|
|
|
|
|
} |
1665
|
|
|
|
|
|
|
elsif ( lc($OSNAME) eq 'linux' ) { |
1666
|
0
|
0
|
|
|
|
0
|
$self->install_module_linux( $module, \%info) and return 1; |
1667
|
|
|
|
|
|
|
}; |
1668
|
|
|
|
|
|
|
|
1669
|
0
|
|
|
|
|
0
|
$self->install_module_cpan( $module ); |
1670
|
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
## no critic ( ProhibitStringyEval ) |
1672
|
0
|
|
|
|
|
0
|
eval "use $module"; |
1673
|
|
|
|
|
|
|
## use critic |
1674
|
0
|
0
|
|
|
|
0
|
if ( ! $EVAL_ERROR ) { |
1675
|
0
|
|
|
|
|
0
|
$log->audit( "$module is installed." ); |
1676
|
0
|
|
|
|
|
0
|
return 1; |
1677
|
|
|
|
|
|
|
}; |
1678
|
0
|
|
|
|
|
0
|
return; |
1679
|
|
|
|
|
|
|
} |
1680
|
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
sub install_module_cpan { |
1682
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1683
|
0
|
|
|
|
|
0
|
my ($module, $version) = @_; |
1684
|
|
|
|
|
|
|
|
1685
|
0
|
|
|
|
|
0
|
print " from CPAN..."; |
1686
|
0
|
|
|
|
|
0
|
require CPAN; |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
# some Linux distros break CPAN by auto/preconfiguring it with no URL mirrors. |
1689
|
|
|
|
|
|
|
# this works around that annoying little habit |
1690
|
3
|
|
|
3
|
|
35
|
no warnings; |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
298
|
|
1691
|
0
|
|
|
|
|
0
|
$CPAN::Config = get_cpan_config(); |
1692
|
3
|
|
|
3
|
|
16
|
use warnings; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
20888
|
|
1693
|
|
|
|
|
|
|
|
1694
|
0
|
0
|
0
|
|
|
0
|
if ( $module eq 'Provision::Unix' && $version ) { |
1695
|
0
|
|
|
|
|
0
|
$module =~ s/\:\:/\-/g; |
1696
|
0
|
|
|
|
|
0
|
$module = "M/MS/MSIMERSON/$module-$version.tar.gz"; |
1697
|
|
|
|
|
|
|
} |
1698
|
0
|
|
|
|
|
0
|
CPAN::Shell->install($module); |
1699
|
|
|
|
|
|
|
} |
1700
|
|
|
|
|
|
|
|
1701
|
|
|
|
|
|
|
sub install_module_darwin { |
1702
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1703
|
0
|
|
|
|
|
0
|
my $module = shift; |
1704
|
|
|
|
|
|
|
|
1705
|
0
|
|
|
|
|
0
|
my $dport = '/opt/local/bin/port'; |
1706
|
0
|
0
|
|
|
|
0
|
return $log->error( "Darwin ports is not installed!", fatal => 0) |
1707
|
|
|
|
|
|
|
if ! -x $dport; |
1708
|
|
|
|
|
|
|
|
1709
|
0
|
|
|
|
|
0
|
my $port = "p5-$module"; |
1710
|
0
|
|
|
|
|
0
|
$port =~ s/::/-/g; |
1711
|
0
|
0
|
|
|
|
0
|
system "sudo $dport install $port" or return 1; |
1712
|
0
|
|
|
|
|
0
|
return; |
1713
|
|
|
|
|
|
|
}; |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
sub install_module_freebsd { |
1716
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1717
|
0
|
|
|
|
|
0
|
my ($module, $info) = @_; |
1718
|
|
|
|
|
|
|
|
1719
|
0
|
|
|
|
|
0
|
my $portname = $info->{port}; # optional override |
1720
|
0
|
0
|
|
|
|
0
|
if ( ! $portname ) { |
1721
|
0
|
|
|
|
|
0
|
$portname = "p5-$module"; |
1722
|
0
|
|
|
|
|
0
|
$portname =~ s/::/-/g; |
1723
|
|
|
|
|
|
|
}; |
1724
|
|
|
|
|
|
|
|
1725
|
0
|
|
|
|
|
0
|
my $r = `/usr/sbin/pkg_info | /usr/bin/grep $portname`; |
1726
|
0
|
0
|
|
|
|
0
|
return $log->audit( "$module is installed as $r") if $r; |
1727
|
|
|
|
|
|
|
|
1728
|
0
|
|
|
|
|
0
|
my $portdir = glob("/usr/ports/*/$portname"); |
1729
|
|
|
|
|
|
|
|
1730
|
0
|
0
|
0
|
|
|
0
|
if ( $portdir && -d $portdir && chdir $portdir ) { |
|
|
|
0
|
|
|
|
|
1731
|
0
|
|
|
|
|
0
|
$log->audit( "installing $module from ports ($portdir)" ); |
1732
|
0
|
|
|
|
|
0
|
system "make clean && make install clean"; |
1733
|
0
|
|
|
|
|
0
|
return 1; |
1734
|
|
|
|
|
|
|
} |
1735
|
0
|
|
|
|
|
0
|
return; |
1736
|
|
|
|
|
|
|
} |
1737
|
|
|
|
|
|
|
|
1738
|
|
|
|
|
|
|
sub install_module_from_src { |
1739
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1740
|
0
|
|
|
|
|
0
|
my %p = validate( @_, { |
1741
|
|
|
|
|
|
|
module => { type=>SCALAR, optional=>0, }, |
1742
|
|
|
|
|
|
|
archive => { type=>SCALAR, optional=>0, }, |
1743
|
|
|
|
|
|
|
site => { type=>SCALAR, optional=>0, }, |
1744
|
|
|
|
|
|
|
url => { type=>SCALAR, optional=>0, }, |
1745
|
|
|
|
|
|
|
src => { type=>SCALAR, optional=>1, default=>'/usr/local/src' }, |
1746
|
|
|
|
|
|
|
targets => { type=>ARRAYREF,optional=>1, }, |
1747
|
|
|
|
|
|
|
%std_opts, |
1748
|
|
|
|
|
|
|
}, |
1749
|
|
|
|
|
|
|
); |
1750
|
|
|
|
|
|
|
|
1751
|
0
|
|
|
|
|
0
|
my ( $module, $site, $url, $src, $targets ) |
1752
|
|
|
|
|
|
|
= ( $p{module}, $p{site}, $p{url}, $p{src}, $p{targets} ); |
1753
|
0
|
|
|
|
|
0
|
my %args = $self->get_std_args( %p ); |
1754
|
|
|
|
|
|
|
|
1755
|
0
|
|
|
|
|
0
|
$self->cwd_source_dir( $src, %args ); |
1756
|
|
|
|
|
|
|
|
1757
|
0
|
|
|
|
|
0
|
$log->audit( "checking for previous build attempts."); |
1758
|
0
|
0
|
|
|
|
0
|
if ( -d $module ) { |
1759
|
0
|
0
|
|
|
|
0
|
if ( ! $self->source_warning( package=>$module, src=>$src, %args ) ) { |
1760
|
0
|
|
|
|
|
0
|
print "\nokay, skipping install.\n"; |
1761
|
0
|
|
|
|
|
0
|
return; |
1762
|
|
|
|
|
|
|
} |
1763
|
0
|
|
|
|
|
0
|
$self->syscmd( cmd => "rm -rf $module", %args ); |
1764
|
|
|
|
|
|
|
} |
1765
|
|
|
|
|
|
|
|
1766
|
|
|
|
|
|
|
$self->sources_get( |
1767
|
0
|
0
|
0
|
|
|
0
|
site => $site, |
1768
|
|
|
|
|
|
|
path => $url, |
1769
|
|
|
|
|
|
|
package => $p{'archive'} || $module, |
1770
|
|
|
|
|
|
|
%args, |
1771
|
|
|
|
|
|
|
) or return; |
1772
|
|
|
|
|
|
|
|
1773
|
0
|
0
|
|
|
|
0
|
$self->extract_archive( $module ) or return; |
1774
|
|
|
|
|
|
|
|
1775
|
0
|
|
|
|
|
0
|
my $found; |
1776
|
0
|
|
|
|
|
0
|
print "looking for $module in $src..."; |
1777
|
0
|
|
|
|
|
0
|
foreach my $file ( $self->get_dir_files( $src ) ) { |
1778
|
|
|
|
|
|
|
|
1779
|
0
|
0
|
|
|
|
0
|
next if ! -d $file; # only check directories |
1780
|
0
|
0
|
|
|
|
0
|
next if $file !~ /$module/; |
1781
|
|
|
|
|
|
|
|
1782
|
0
|
|
|
|
|
0
|
print "found: $file\n"; |
1783
|
0
|
|
|
|
|
0
|
$found++; |
1784
|
0
|
|
|
|
|
0
|
chdir $file; |
1785
|
|
|
|
|
|
|
|
1786
|
0
|
0
|
0
|
|
|
0
|
unless ( @$targets[0] && @$targets[0] ne "" ) { |
1787
|
0
|
|
|
|
|
0
|
$log->audit( "using default targets." ); |
1788
|
0
|
|
|
|
|
0
|
$targets = [ "perl Makefile.PL", "make", "make install" ]; |
1789
|
|
|
|
|
|
|
} |
1790
|
|
|
|
|
|
|
|
1791
|
0
|
|
|
|
|
0
|
print "building with targets " . join( ", ", @$targets ) . "\n"; |
1792
|
0
|
|
|
|
|
0
|
foreach (@$targets) { |
1793
|
0
|
0
|
|
|
|
0
|
return $log->error( "$_ failed!", %args) |
1794
|
|
|
|
|
|
|
if ! $self->syscmd( cmd => $_ , %args); |
1795
|
|
|
|
|
|
|
} |
1796
|
|
|
|
|
|
|
|
1797
|
0
|
|
|
|
|
0
|
chdir('..'); |
1798
|
0
|
|
|
|
|
0
|
$self->syscmd( cmd => "rm -rf $file", debug=>0); |
1799
|
0
|
|
|
|
|
0
|
last; |
1800
|
|
|
|
|
|
|
} |
1801
|
|
|
|
|
|
|
|
1802
|
0
|
|
|
|
|
0
|
return $found; |
1803
|
|
|
|
|
|
|
} |
1804
|
|
|
|
|
|
|
|
1805
|
|
|
|
|
|
|
sub install_module_linux { |
1806
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1807
|
0
|
|
|
|
|
0
|
my ($module, $info ) = @_; |
1808
|
0
|
|
|
|
|
0
|
my $rpm = $info->{rpm}; |
1809
|
0
|
0
|
|
|
|
0
|
if ( $rpm ) { |
1810
|
0
|
|
|
|
|
0
|
my $portname = "perl-$rpm"; |
1811
|
0
|
|
|
|
|
0
|
$portname =~ s/::/-/g; |
1812
|
0
|
|
|
|
|
0
|
my $yum = '/usr/bin/yum'; |
1813
|
0
|
0
|
|
|
|
0
|
system "$yum -y install $portname" if -x $yum; |
1814
|
|
|
|
|
|
|
} |
1815
|
|
|
|
|
|
|
}; |
1816
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
sub is_interactive { |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
## no critic |
1820
|
|
|
|
|
|
|
# borrowed from IO::Interactive |
1821
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1822
|
0
|
|
|
|
|
0
|
my ($out_handle) = ( @_, select ); # Default to default output handle |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
# Not interactive if output is not to terminal... |
1825
|
0
|
0
|
|
|
|
0
|
return if not -t $out_handle; |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
# If *ARGV is opened, we're interactive if... |
1828
|
0
|
0
|
|
|
|
0
|
if ( openhandle * ARGV ) { |
1829
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
# ...it's currently opened to the magic '-' file |
1831
|
0
|
0
|
0
|
|
|
0
|
return -t *STDIN if defined $ARGV && $ARGV eq '-'; |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
# ...it's at end-of-file and the next file is the magic '-' file |
1834
|
0
|
0
|
0
|
|
|
0
|
return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV; |
1835
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
# ...it's directly attached to the terminal |
1837
|
0
|
|
|
|
|
0
|
return -t *ARGV; |
1838
|
|
|
|
|
|
|
}; |
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
# If *ARGV isn't opened, it will be interactive if *STDIN is attached |
1841
|
|
|
|
|
|
|
# to a terminal and either there are no files specified on the command line |
1842
|
|
|
|
|
|
|
# or if there are files and the first is the magic '-' file |
1843
|
0
|
|
0
|
|
|
0
|
return -t *STDIN && ( @ARGV == 0 || $ARGV[0] eq '-' ); |
1844
|
|
|
|
|
|
|
} |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
sub is_process_running { |
1847
|
2
|
|
|
2
|
1
|
15
|
my ( $self, $process ) = @_; |
1848
|
|
|
|
|
|
|
|
1849
|
2
|
|
|
|
|
27
|
my $ps = $self->find_bin( 'ps', debug => 0 ); |
1850
|
|
|
|
|
|
|
|
1851
|
2
|
50
|
|
|
|
747
|
if ( lc($OSNAME) =~ /solaris/i ) { $ps .= ' -ef'; } |
|
0
|
50
|
|
|
|
0
|
|
|
|
50
|
|
|
|
|
|
1852
|
0
|
|
|
|
|
0
|
elsif ( lc($OSNAME) =~ /irix/i ) { $ps .= ' -ef'; } |
1853
|
2
|
|
|
|
|
20
|
elsif ( lc($OSNAME) =~ /linux/i ) { $ps .= ' -efw'; } |
1854
|
0
|
|
|
|
|
0
|
else { $ps .= ' axww'; }; |
1855
|
|
|
|
|
|
|
|
1856
|
2
|
|
|
|
|
34203
|
my @procs = `$ps`; |
1857
|
2
|
|
|
|
|
38
|
chomp @procs; |
1858
|
2
|
|
|
|
|
42
|
return scalar grep {/$process/i} @procs; |
|
24
|
|
|
|
|
270
|
|
1859
|
|
|
|
|
|
|
} |
1860
|
|
|
|
|
|
|
|
1861
|
|
|
|
|
|
|
sub is_readable { |
1862
|
2
|
|
|
2
|
1
|
6
|
my $self = shift; |
1863
|
2
|
50
|
|
|
|
7
|
my $file = shift or die "missing file or dir name\n"; |
1864
|
2
|
|
|
|
|
68
|
my %p = validate( @_, { %std_opts } ); |
1865
|
|
|
|
|
|
|
|
1866
|
2
|
|
|
|
|
15
|
my %args = ( debug => $p{debug}, fatal => $p{fatal} ); |
1867
|
|
|
|
|
|
|
|
1868
|
2
|
100
|
|
|
|
52
|
-e $file or return $log->error( "$file does not exist.", %args); |
1869
|
1
|
50
|
|
|
|
22
|
-r $file or return $log->error( "$file is not readable by you (" |
1870
|
|
|
|
|
|
|
. getpwuid($>) |
1871
|
|
|
|
|
|
|
. "). You need to fix this, using chown or chmod.", %args); |
1872
|
|
|
|
|
|
|
|
1873
|
1
|
|
|
|
|
6
|
return 1; |
1874
|
|
|
|
|
|
|
} |
1875
|
|
|
|
|
|
|
|
1876
|
|
|
|
|
|
|
sub is_writable { |
1877
|
22
|
|
|
22
|
1
|
45
|
my $self = shift; |
1878
|
22
|
50
|
|
|
|
64
|
my $file = shift or die "missing file or dir name\n"; |
1879
|
|
|
|
|
|
|
|
1880
|
22
|
|
|
|
|
768
|
my %p = validate( @_, { %std_opts } ); |
1881
|
22
|
|
|
|
|
180
|
my %args = $self->get_std_args( %p ); |
1882
|
|
|
|
|
|
|
|
1883
|
22
|
|
|
|
|
63
|
my $nl = "\n"; |
1884
|
22
|
50
|
|
|
|
76
|
$nl = " " if ( $ENV{GATEWAY_INTERFACE} ); |
1885
|
|
|
|
|
|
|
|
1886
|
22
|
100
|
|
|
|
998
|
if ( !-e $file ) { |
1887
|
|
|
|
|
|
|
|
1888
|
8
|
|
|
|
|
561
|
my ( $base, $path, $suffix ) = fileparse($file); |
1889
|
|
|
|
|
|
|
|
1890
|
8
|
50
|
33
|
|
|
389
|
return $log->error( "is_writable: $path not writable by " |
1891
|
|
|
|
|
|
|
. getpwuid($>) |
1892
|
|
|
|
|
|
|
. "$nl$nl", %args) if (-e $path && !-w $path); |
1893
|
8
|
|
|
|
|
72
|
return 1; |
1894
|
|
|
|
|
|
|
} |
1895
|
|
|
|
|
|
|
|
1896
|
14
|
50
|
|
|
|
415
|
return $log->error( " $file not writable by " . getpwuid($>) . "$nl$nl", %args ) if ! -w $file; |
1897
|
|
|
|
|
|
|
|
1898
|
14
|
|
|
|
|
97
|
$log->audit( "$file is writable" ); |
1899
|
14
|
|
|
|
|
171
|
return 1; |
1900
|
|
|
|
|
|
|
} |
1901
|
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
|
sub logfile_append { |
1903
|
3
|
|
|
3
|
1
|
41
|
my $self = shift; |
1904
|
3
|
|
|
|
|
201
|
my %p = validate( |
1905
|
|
|
|
|
|
|
@_, |
1906
|
|
|
|
|
|
|
{ 'file' => { type => SCALAR, optional => 0, }, |
1907
|
|
|
|
|
|
|
'lines' => { type => ARRAYREF, optional => 0, }, |
1908
|
|
|
|
|
|
|
'prog' => { type => BOOLEAN, optional => 1, default => 0, }, |
1909
|
|
|
|
|
|
|
%std_opts, |
1910
|
|
|
|
|
|
|
}, |
1911
|
|
|
|
|
|
|
); |
1912
|
|
|
|
|
|
|
|
1913
|
3
|
|
|
|
|
30
|
my ( $file, $lines ) = ( $p{file}, $p{lines} ); |
1914
|
3
|
|
|
|
|
36
|
my %args = $self->get_std_args( %p ); |
1915
|
|
|
|
|
|
|
|
1916
|
3
|
|
|
|
|
21
|
my ( $dd, $mm, $yy, $lm, $hh, $mn, $ss ) = $self->get_the_date( %args ); |
1917
|
|
|
|
|
|
|
|
1918
|
3
|
50
|
|
|
|
204
|
open my $LOG_FILE, '>>', $file |
1919
|
|
|
|
|
|
|
or return $log->error( "couldn't open $file: $OS_ERROR", %args); |
1920
|
|
|
|
|
|
|
|
1921
|
3
|
|
|
|
|
34
|
print $LOG_FILE "$yy-$mm-$dd $hh:$mn:$ss $p{prog} "; |
1922
|
|
|
|
|
|
|
|
1923
|
3
|
|
|
|
|
6
|
my $i; |
1924
|
3
|
|
|
|
|
8
|
foreach (@$lines) { print $LOG_FILE "$_ "; $i++ } |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
12
|
|
1925
|
|
|
|
|
|
|
|
1926
|
3
|
|
|
|
|
9
|
print $LOG_FILE "\n"; |
1927
|
3
|
|
|
|
|
84
|
close $LOG_FILE; |
1928
|
|
|
|
|
|
|
|
1929
|
3
|
|
|
|
|
20
|
$log->audit( "logfile_append wrote $i lines to $file", %args ); |
1930
|
3
|
|
|
|
|
36
|
return 1; |
1931
|
|
|
|
|
|
|
} |
1932
|
|
|
|
|
|
|
|
1933
|
|
|
|
|
|
|
sub mail_toaster { |
1934
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1935
|
0
|
|
|
|
|
0
|
$self->install_module( 'Mail::Toaster' ); |
1936
|
|
|
|
|
|
|
} |
1937
|
|
|
|
|
|
|
|
1938
|
|
|
|
|
|
|
sub mkdir_system { |
1939
|
1
|
|
|
1
|
1
|
458
|
my $self = shift; |
1940
|
1
|
|
|
|
|
52
|
my %p = validate( |
1941
|
|
|
|
|
|
|
@_, |
1942
|
|
|
|
|
|
|
{ 'dir' => { type => SCALAR, optional => 0, }, |
1943
|
|
|
|
|
|
|
'mode' => { type => SCALAR, optional => 1, }, |
1944
|
|
|
|
|
|
|
'sudo' => { type => BOOLEAN, optional => 1, default => 0 }, |
1945
|
|
|
|
|
|
|
%std_opts, |
1946
|
|
|
|
|
|
|
} |
1947
|
|
|
|
|
|
|
); |
1948
|
|
|
|
|
|
|
|
1949
|
1
|
|
|
|
|
17
|
my ( $dir, $mode ) = ( $p{dir}, $p{mode} ); |
1950
|
1
|
|
|
|
|
5
|
my %args = $self->get_std_args( %p ); |
1951
|
|
|
|
|
|
|
|
1952
|
1
|
50
|
|
|
|
58
|
return $log->audit( "mkdir_system: $dir already exists.") if -d $dir; |
1953
|
|
|
|
|
|
|
|
1954
|
1
|
50
|
|
|
|
12
|
my $mkdir = $self->find_bin( 'mkdir', %args) or return; |
1955
|
|
|
|
|
|
|
|
1956
|
|
|
|
|
|
|
# if we are root, just do it (no sudo nonsense) |
1957
|
1
|
50
|
|
|
|
20
|
if ( $< == 0 ) { |
1958
|
1
|
50
|
|
|
|
27
|
$self->syscmd( "$mkdir -p $dir", %args) or return; |
1959
|
1
|
50
|
|
|
|
26
|
$self->chmod( dir => $dir, mode => $mode, %args ) if $mode; |
1960
|
|
|
|
|
|
|
|
1961
|
1
|
50
|
|
|
|
109
|
return 1 if -d $dir; |
1962
|
0
|
|
|
|
|
0
|
return $log->error( "failed to create $dir", %args); |
1963
|
|
|
|
|
|
|
} |
1964
|
|
|
|
|
|
|
|
1965
|
0
|
0
|
|
|
|
0
|
if ( $p{sudo} ) { |
1966
|
0
|
|
|
|
|
0
|
my $sudo = $self->sudo(); |
1967
|
|
|
|
|
|
|
|
1968
|
0
|
|
|
|
|
0
|
$log->audit( "trying $sudo $mkdir -p $dir"); |
1969
|
0
|
|
|
|
|
0
|
$self->syscmd( "$sudo $mkdir -p $dir", %args); |
1970
|
|
|
|
|
|
|
|
1971
|
0
|
|
|
|
|
0
|
$log->audit( "setting ownership to $<."); |
1972
|
0
|
|
|
|
|
0
|
my $chown = $self->find_bin( 'chown', %args); |
1973
|
0
|
|
|
|
|
0
|
$self->syscmd( "$sudo $chown $< $dir", %args); |
1974
|
|
|
|
|
|
|
|
1975
|
0
|
0
|
|
|
|
0
|
$self->chmod( dir => $dir, mode => $mode, sudo => $sudo, %args) |
1976
|
|
|
|
|
|
|
if $mode; |
1977
|
0
|
0
|
|
|
|
0
|
return -d $dir ? 1 : 0; |
1978
|
|
|
|
|
|
|
} |
1979
|
|
|
|
|
|
|
|
1980
|
0
|
|
|
|
|
0
|
$log->audit( "trying mkdir -p $dir" ); |
1981
|
|
|
|
|
|
|
|
1982
|
|
|
|
|
|
|
# no root and no sudo, just try and see what happens |
1983
|
0
|
0
|
|
|
|
0
|
$self->syscmd( "$mkdir -p $dir", %args ) or return; |
1984
|
|
|
|
|
|
|
|
1985
|
0
|
0
|
|
|
|
0
|
$self->chmod( dir => $dir, mode => $mode, %args) if $mode; |
1986
|
|
|
|
|
|
|
|
1987
|
0
|
0
|
|
|
|
0
|
return $log->audit( "mkdir_system created $dir" ) if -d $dir; |
1988
|
0
|
|
|
|
|
0
|
return $log->error( '', %args ); |
1989
|
|
|
|
|
|
|
} |
1990
|
|
|
|
|
|
|
|
1991
|
|
|
|
|
|
|
sub path_parse { |
1992
|
|
|
|
|
|
|
|
1993
|
|
|
|
|
|
|
# code left here for reference, use File::Basename instead |
1994
|
1
|
|
|
1
|
0
|
3
|
my ( $self, $dir ) = @_; |
1995
|
|
|
|
|
|
|
|
1996
|
|
|
|
|
|
|
# if it ends with a /, chop if off |
1997
|
1
|
50
|
|
|
|
15
|
if ( $dir =~ q{/$} ) { chop $dir } |
|
0
|
|
|
|
|
0
|
|
1998
|
|
|
|
|
|
|
|
1999
|
|
|
|
|
|
|
# get the position of the last / in the path |
2000
|
1
|
|
|
|
|
7
|
my $rindex = rindex( $dir, "/" ); |
2001
|
|
|
|
|
|
|
|
2002
|
|
|
|
|
|
|
# grabs everything up to the last / |
2003
|
1
|
|
|
|
|
6
|
my $updir = substr( $dir, 0, $rindex ); |
2004
|
1
|
|
|
|
|
4
|
$rindex++; |
2005
|
|
|
|
|
|
|
|
2006
|
|
|
|
|
|
|
# matches from the last / char +1 to the end of string |
2007
|
1
|
|
|
|
|
2
|
my $curdir = substr( $dir, $rindex ); |
2008
|
|
|
|
|
|
|
|
2009
|
1
|
|
|
|
|
9
|
return $updir, $curdir; |
2010
|
|
|
|
|
|
|
} |
2011
|
|
|
|
|
|
|
|
2012
|
|
|
|
|
|
|
sub check_pidfile { |
2013
|
3
|
|
|
3
|
1
|
4
|
my $self = shift; |
2014
|
3
|
|
|
|
|
9
|
my $file = shift; |
2015
|
3
|
|
|
|
|
60
|
my %p = validate( @_, { %std_opts } ); |
2016
|
3
|
|
|
|
|
24
|
my %args = $self->get_std_args( %p ); |
2017
|
|
|
|
|
|
|
|
2018
|
3
|
50
|
|
|
|
8
|
return $log->error( "missing filename", %args) if ! $file; |
2019
|
3
|
100
|
100
|
|
|
119
|
return $log->error( "$file is not a regular file", %args) |
2020
|
|
|
|
|
|
|
if ( -e $file && !-f $file ); |
2021
|
|
|
|
|
|
|
|
2022
|
|
|
|
|
|
|
# test if file & enclosing directory is writable, revert to /tmp if not |
2023
|
|
|
|
|
|
|
$self->is_writable( $file, %args) |
2024
|
2
|
50
|
|
|
|
16
|
or do { |
2025
|
0
|
|
|
|
|
0
|
my ( $base, $path, $suffix ) = fileparse($file); |
2026
|
0
|
|
|
|
|
0
|
$log->audit( "NOTICE: using /tmp for file, $path is not writable!", %args); |
2027
|
0
|
|
|
|
|
0
|
$file = "/tmp/$base"; |
2028
|
|
|
|
|
|
|
}; |
2029
|
|
|
|
|
|
|
|
2030
|
|
|
|
|
|
|
# if it does not exist |
2031
|
2
|
100
|
|
|
|
225
|
if ( !-e $file ) { |
2032
|
1
|
|
|
|
|
24
|
$log->audit( "writing process id $PROCESS_ID to $file..."); |
2033
|
1
|
50
|
|
|
|
13
|
$self->file_write( $file, lines => [$PROCESS_ID], %args) and return $file; |
2034
|
|
|
|
|
|
|
}; |
2035
|
|
|
|
|
|
|
|
2036
|
1
|
|
|
|
|
17
|
my $age = time() - stat($file)->mtime; |
2037
|
|
|
|
|
|
|
|
2038
|
1
|
50
|
|
|
|
280
|
if ( $age < 1200 ) { # less than 20 minutes old |
|
|
0
|
|
|
|
|
|
2039
|
1
|
|
|
|
|
14
|
return $log->error( "check_pidfile: $file is " . $age / 60 |
2040
|
|
|
|
|
|
|
. " minutes old and might still be running. If it is not running," |
2041
|
|
|
|
|
|
|
. " please remove the file (rm $file).", %args); |
2042
|
|
|
|
|
|
|
} |
2043
|
|
|
|
|
|
|
elsif ( $age < 3600 ) { # 1 hour |
2044
|
0
|
|
|
|
|
0
|
return $log->error( "check_pidfile: $file is " . $age / 60 |
2045
|
|
|
|
|
|
|
. " minutes old and might still be running. If it is not running," |
2046
|
|
|
|
|
|
|
. " please remove the pidfile. (rm $file)", %args); |
2047
|
|
|
|
|
|
|
} |
2048
|
|
|
|
|
|
|
else { |
2049
|
0
|
|
|
|
|
0
|
$log->audit( "check_pidfile: $file is $age seconds old, ignoring.", %args); |
2050
|
|
|
|
|
|
|
} |
2051
|
|
|
|
|
|
|
|
2052
|
0
|
|
|
|
|
0
|
return $file; |
2053
|
|
|
|
|
|
|
} |
2054
|
|
|
|
|
|
|
|
2055
|
|
|
|
|
|
|
sub parse_config { |
2056
|
3
|
|
|
3
|
0
|
511
|
my $self = shift; |
2057
|
3
|
50
|
|
|
|
13
|
my $file = shift or die "missing file name"; |
2058
|
3
|
|
|
|
|
97
|
my %p = validate( @_, { |
2059
|
|
|
|
|
|
|
etcdir => { type=>SCALAR, optional=>1, }, |
2060
|
|
|
|
|
|
|
%std_opts, |
2061
|
|
|
|
|
|
|
}, |
2062
|
|
|
|
|
|
|
); |
2063
|
|
|
|
|
|
|
|
2064
|
3
|
|
|
|
|
40
|
my %args = $self->get_std_args( %p ); |
2065
|
|
|
|
|
|
|
|
2066
|
3
|
100
|
|
|
|
69
|
if ( ! -f $file ) { $file = $self->find_config( $file, %p ); }; |
|
1
|
|
|
|
|
16
|
|
2067
|
|
|
|
|
|
|
|
2068
|
3
|
100
|
66
|
|
|
65
|
if ( ! $file || ! -r $file ) { |
2069
|
1
|
|
|
|
|
14
|
return $log->error( "could not find config file!", %args); |
2070
|
|
|
|
|
|
|
}; |
2071
|
|
|
|
|
|
|
|
2072
|
2
|
|
|
|
|
6
|
my %hash; |
2073
|
2
|
|
|
|
|
26
|
$log->audit( " read config from $file"); |
2074
|
|
|
|
|
|
|
|
2075
|
2
|
|
|
|
|
18
|
my @config = $self->file_read( $file ); |
2076
|
2
|
|
|
|
|
14
|
foreach ( @config ) { |
2077
|
300
|
100
|
|
|
|
596
|
next if ! $_; |
2078
|
236
|
|
|
|
|
322
|
chomp; |
2079
|
236
|
100
|
|
|
|
521
|
next if $_ =~ /^#/; # skip lines beginning with # |
2080
|
34
|
50
|
|
|
|
89
|
next if $_ =~ /^[\s+]?$/; # skip empty lines |
2081
|
|
|
|
|
|
|
|
2082
|
34
|
|
|
|
|
80
|
my ( $key, $val ) = $self->parse_line( $_ ); |
2083
|
|
|
|
|
|
|
|
2084
|
34
|
50
|
|
|
|
121
|
next if ! $key; |
2085
|
34
|
|
|
|
|
114
|
$hash{$key} = $val; |
2086
|
|
|
|
|
|
|
} |
2087
|
|
|
|
|
|
|
|
2088
|
2
|
|
|
|
|
62
|
return \%hash; |
2089
|
|
|
|
|
|
|
} |
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
sub parse_line { |
2092
|
38
|
|
|
38
|
0
|
2172
|
my $self = shift; |
2093
|
38
|
|
|
|
|
36
|
my $line = shift; |
2094
|
38
|
|
|
|
|
412
|
my %p = validate( @_, { |
2095
|
|
|
|
|
|
|
strip => { type => BOOLEAN, optional=>1, default=>1 }, |
2096
|
|
|
|
|
|
|
}, |
2097
|
|
|
|
|
|
|
); |
2098
|
|
|
|
|
|
|
|
2099
|
38
|
|
|
|
|
133
|
my $strip = $p{strip}; |
2100
|
|
|
|
|
|
|
|
2101
|
|
|
|
|
|
|
# this regexp must match and return these patterns |
2102
|
|
|
|
|
|
|
# localhost1 = localhost, disk, da0, disk_da0 |
2103
|
|
|
|
|
|
|
# hosts = localhost lab.simerson.net seattle.simerson.net |
2104
|
|
|
|
|
|
|
|
2105
|
38
|
|
|
|
|
656
|
my ( $key, $val ) = $line =~ /\A |
2106
|
|
|
|
|
|
|
\s* # any amount of leading white space, greedy |
2107
|
|
|
|
|
|
|
(.*?) # all characters, non greedy |
2108
|
|
|
|
|
|
|
\s* # any amount of white space, greedy |
2109
|
|
|
|
|
|
|
= |
2110
|
|
|
|
|
|
|
\s* # same, except on the other side of the = |
2111
|
|
|
|
|
|
|
(.*?) |
2112
|
|
|
|
|
|
|
\s* |
2113
|
|
|
|
|
|
|
\z/xms; |
2114
|
|
|
|
|
|
|
|
2115
|
|
|
|
|
|
|
# remove any comments |
2116
|
38
|
50
|
66
|
|
|
298
|
if ( $strip && $val && $val =~ /#/ ) { |
|
|
|
66
|
|
|
|
|
2117
|
|
|
|
|
|
|
|
2118
|
|
|
|
|
|
|
# removes everything from a # to the right, including |
2119
|
|
|
|
|
|
|
# any spaces to the left of the # symbol. |
2120
|
0
|
|
|
|
|
0
|
($val) = $val =~ /(.*?\S)\s*#/; |
2121
|
|
|
|
|
|
|
} |
2122
|
|
|
|
|
|
|
|
2123
|
38
|
|
|
|
|
125
|
return ( $key, $val ); |
2124
|
|
|
|
|
|
|
} |
2125
|
|
|
|
|
|
|
|
2126
|
|
|
|
|
|
|
sub provision_unix { |
2127
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
2128
|
0
|
|
|
|
|
0
|
$self->install_module( 'Provision::Unix' ); |
2129
|
|
|
|
|
|
|
} |
2130
|
|
|
|
|
|
|
|
2131
|
|
|
|
|
|
|
sub regexp_test { |
2132
|
1
|
|
|
1
|
1
|
1037
|
my $self = shift; |
2133
|
1
|
|
|
|
|
66
|
my %p = validate( |
2134
|
|
|
|
|
|
|
@_, |
2135
|
|
|
|
|
|
|
{ 'exp' => { type => SCALAR }, |
2136
|
|
|
|
|
|
|
'string' => { type => SCALAR }, |
2137
|
|
|
|
|
|
|
'pbp' => { type => BOOLEAN, optional => 1, default => 0 }, |
2138
|
|
|
|
|
|
|
%std_opts, |
2139
|
|
|
|
|
|
|
}, |
2140
|
|
|
|
|
|
|
); |
2141
|
|
|
|
|
|
|
|
2142
|
1
|
|
|
|
|
14
|
my $debug = $p{debug}; |
2143
|
1
|
|
|
|
|
4
|
my ( $exp, $string, $pbp ) = ( $p{exp}, $p{string}, $p{pbp} ); |
2144
|
|
|
|
|
|
|
|
2145
|
1
|
50
|
|
|
|
12
|
if ($pbp) { |
2146
|
0
|
0
|
|
|
|
0
|
if ( $string =~ m{($exp)}xms ) { |
2147
|
0
|
0
|
|
|
|
0
|
print "\t Matched pbp: |$`<$&>$'|\n" if $debug; |
2148
|
0
|
|
|
|
|
0
|
return $1; |
2149
|
|
|
|
|
|
|
} |
2150
|
|
|
|
|
|
|
else { |
2151
|
0
|
0
|
|
|
|
0
|
print "\t No match.\n" if $debug; |
2152
|
0
|
|
|
|
|
0
|
return; |
2153
|
|
|
|
|
|
|
} |
2154
|
|
|
|
|
|
|
} |
2155
|
|
|
|
|
|
|
|
2156
|
1
|
50
|
|
|
|
43
|
if ( $string =~ m{($exp)} ) { |
2157
|
1
|
50
|
|
|
|
5
|
print "\t Matched: |$`<$&>$'|\n" if $debug; |
2158
|
1
|
|
|
|
|
14
|
return $1; |
2159
|
|
|
|
|
|
|
} |
2160
|
|
|
|
|
|
|
|
2161
|
0
|
0
|
|
|
|
0
|
print "\t No match.\n" if $debug; |
2162
|
0
|
|
|
|
|
0
|
return; |
2163
|
|
|
|
|
|
|
} |
2164
|
|
|
|
|
|
|
|
2165
|
|
|
|
|
|
|
sub sources_get { |
2166
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
2167
|
0
|
|
|
|
|
0
|
my %p = validate( |
2168
|
|
|
|
|
|
|
@_, |
2169
|
|
|
|
|
|
|
{ 'package' => { type => SCALAR, optional => 0 }, |
2170
|
|
|
|
|
|
|
site => { type => SCALAR, optional => 0 }, |
2171
|
|
|
|
|
|
|
path => { type => SCALAR, optional => 1 }, |
2172
|
|
|
|
|
|
|
%std_opts, |
2173
|
|
|
|
|
|
|
}, |
2174
|
|
|
|
|
|
|
); |
2175
|
|
|
|
|
|
|
|
2176
|
0
|
|
|
|
|
0
|
my ( $package, $site, $path ) = ( $p{package}, $p{site}, $p{path} ); |
2177
|
0
|
|
|
|
|
0
|
my %args = $self->get_std_args( %p ); |
2178
|
|
|
|
|
|
|
|
2179
|
0
|
|
|
|
|
0
|
$log->audit( "sources_get: fetching $package from site $site\n\t path: $path"); |
2180
|
|
|
|
|
|
|
|
2181
|
0
|
|
|
|
|
0
|
my @extensions = qw/ tar.gz tgz tar.bz2 tbz2 /; |
2182
|
|
|
|
|
|
|
|
2183
|
0
|
0
|
|
|
|
0
|
my $filet = $self->find_bin( 'file', %args) or return; |
2184
|
0
|
0
|
|
|
|
0
|
my $grep = $self->find_bin( 'grep', %args) or return; |
2185
|
|
|
|
|
|
|
|
2186
|
0
|
|
|
|
|
0
|
foreach my $ext (@extensions) { |
2187
|
|
|
|
|
|
|
|
2188
|
0
|
|
|
|
|
0
|
my $tarball = "$package.$ext"; |
2189
|
0
|
0
|
|
|
|
0
|
next if !-e $tarball; |
2190
|
0
|
0
|
|
|
|
0
|
$log->audit( " found $tarball!") if -e $tarball; |
2191
|
|
|
|
|
|
|
|
2192
|
0
|
0
|
|
|
|
0
|
if (`$filet $tarball | $grep compress`) { |
2193
|
0
|
0
|
|
|
|
0
|
$self->yes_or_no( "$tarball exists, shall I use it?: ") |
2194
|
|
|
|
|
|
|
and return $log->audit( " ok, using existing archive: $tarball"); |
2195
|
|
|
|
|
|
|
} |
2196
|
|
|
|
|
|
|
|
2197
|
0
|
|
|
|
|
0
|
$self->file_delete( $tarball, %args ); |
2198
|
|
|
|
|
|
|
} |
2199
|
|
|
|
|
|
|
|
2200
|
0
|
|
|
|
|
0
|
foreach my $ext (@extensions) { |
2201
|
0
|
|
|
|
|
0
|
my $tarball = "$package.$ext"; |
2202
|
|
|
|
|
|
|
|
2203
|
0
|
|
|
|
|
0
|
$log->audit( "sources_get: fetching $site$path/$tarball"); |
2204
|
|
|
|
|
|
|
|
2205
|
0
|
0
|
|
|
|
0
|
$self->get_url( "$site$path/$tarball", fatal => 0) |
2206
|
|
|
|
|
|
|
or return $log->error( "couldn't fetch $site$path/$tarball", %args); |
2207
|
|
|
|
|
|
|
|
2208
|
0
|
0
|
|
|
|
0
|
next if ! -e $tarball; |
2209
|
|
|
|
|
|
|
|
2210
|
0
|
|
|
|
|
0
|
$log->audit( " sources_get: testing $tarball "); |
2211
|
|
|
|
|
|
|
|
2212
|
0
|
0
|
|
|
|
0
|
if (`$filet $tarball | $grep zip`) { |
2213
|
0
|
|
|
|
|
0
|
$log->audit( " sources_get: looks good!"); |
2214
|
0
|
|
|
|
|
0
|
return 1; |
2215
|
|
|
|
|
|
|
}; |
2216
|
|
|
|
|
|
|
|
2217
|
0
|
|
|
|
|
0
|
$log->audit( " oops, is not [b|g]zipped data!"); |
2218
|
0
|
|
|
|
|
0
|
$self->file_delete( $tarball, %args); |
2219
|
|
|
|
|
|
|
} |
2220
|
|
|
|
|
|
|
|
2221
|
0
|
|
|
|
|
0
|
return $log->error( "unable to get $package", %args ); |
2222
|
|
|
|
|
|
|
} |
2223
|
|
|
|
|
|
|
|
2224
|
|
|
|
|
|
|
sub source_warning { |
2225
|
1
|
|
|
1
|
1
|
9
|
my $self = shift; |
2226
|
1
|
|
|
|
|
79
|
my %p = validate( |
2227
|
|
|
|
|
|
|
@_, |
2228
|
|
|
|
|
|
|
{ 'package' => { type => SCALAR, }, |
2229
|
|
|
|
|
|
|
'clean' => { type => BOOLEAN, optional => 1, default => 1 }, |
2230
|
|
|
|
|
|
|
'src' => { |
2231
|
|
|
|
|
|
|
type => SCALAR, |
2232
|
|
|
|
|
|
|
optional => 1, |
2233
|
|
|
|
|
|
|
default => "/usr/local/src" |
2234
|
|
|
|
|
|
|
}, |
2235
|
|
|
|
|
|
|
'timeout' => { type => SCALAR, optional => 1, default => 60 }, |
2236
|
|
|
|
|
|
|
%std_opts, |
2237
|
|
|
|
|
|
|
}, |
2238
|
|
|
|
|
|
|
); |
2239
|
|
|
|
|
|
|
|
2240
|
1
|
|
|
|
|
12
|
my ( $package, $src ) = ( $p{package}, $p{src} ); |
2241
|
1
|
|
|
|
|
7
|
my %args = $self->get_std_args( %p ); |
2242
|
|
|
|
|
|
|
|
2243
|
1
|
50
|
|
|
|
37
|
return $log->audit( "$package sources not present.", %args ) if !-d $package; |
2244
|
|
|
|
|
|
|
|
2245
|
0
|
0
|
|
|
|
0
|
if ( -e $package ) { |
2246
|
0
|
|
|
|
|
0
|
print " |
2247
|
|
|
|
|
|
|
$package sources are already present, indicating that you've already |
2248
|
|
|
|
|
|
|
installed $package. If you want to reinstall it, remove the existing |
2249
|
|
|
|
|
|
|
sources (rm -r $src/$package) and re-run this script\n\n"; |
2250
|
0
|
0
|
|
|
|
0
|
return if !$p{clean}; |
2251
|
|
|
|
|
|
|
} |
2252
|
|
|
|
|
|
|
|
2253
|
0
|
0
|
|
|
|
0
|
if ( !$self->yes_or_no( "\n\tMay I remove the sources for you?", timeout => $p{timeout} ) ) { |
2254
|
0
|
|
|
|
|
0
|
print "\nOK then, skipping $package install.\n\n"; |
2255
|
0
|
|
|
|
|
0
|
return; |
2256
|
|
|
|
|
|
|
}; |
2257
|
|
|
|
|
|
|
|
2258
|
0
|
|
|
|
|
0
|
$log->audit( " wd: " . cwd ); |
2259
|
0
|
|
|
|
|
0
|
$log->audit( " deleting $src/$package"); |
2260
|
|
|
|
|
|
|
|
2261
|
0
|
0
|
|
|
|
0
|
return $log->error( "failed to delete $package: $OS_ERROR", %args ) |
2262
|
|
|
|
|
|
|
if ! rmtree "$src/$package"; |
2263
|
0
|
|
|
|
|
0
|
return 1; |
2264
|
|
|
|
|
|
|
} |
2265
|
|
|
|
|
|
|
|
2266
|
|
|
|
|
|
|
sub sudo { |
2267
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
2268
|
1
|
|
|
|
|
31
|
my %p = validate( @_, { %std_opts } ); |
2269
|
|
|
|
|
|
|
|
2270
|
|
|
|
|
|
|
# if we are running as root via $< |
2271
|
1
|
50
|
|
|
|
22
|
if ( $REAL_USER_ID == 0 ) { |
2272
|
1
|
|
|
|
|
6
|
$log->audit( "sudo: you are root, sudo isn't necessary."); |
2273
|
1
|
|
|
|
|
17
|
return ''; # return an empty string, purposefully |
2274
|
|
|
|
|
|
|
} |
2275
|
|
|
|
|
|
|
|
2276
|
0
|
|
|
|
|
0
|
my $sudo; |
2277
|
0
|
|
|
|
|
0
|
my $path_to_sudo = $self->find_bin( 'sudo', fatal => 0 ); |
2278
|
|
|
|
|
|
|
|
2279
|
|
|
|
|
|
|
# sudo is installed |
2280
|
0
|
0
|
0
|
|
|
0
|
if ( $path_to_sudo && -x $path_to_sudo ) { |
2281
|
0
|
|
|
|
|
0
|
$log->audit( "sudo: sudo was found at $path_to_sudo."); |
2282
|
0
|
|
|
|
|
0
|
return "$path_to_sudo -p 'Password for %u@%h:'"; |
2283
|
|
|
|
|
|
|
} |
2284
|
|
|
|
|
|
|
|
2285
|
0
|
|
|
|
|
0
|
$log->audit( "\nWARNING: Couldn't find sudo. This may not be a problem but some features require root permissions and will not work without them. Having sudo can allow legitimate and limited root permission to non-root users. Some features of Apache::Logmonster may not work as expected without it.\n"); |
2286
|
|
|
|
|
|
|
|
2287
|
|
|
|
|
|
|
# try installing sudo |
2288
|
0
|
0
|
|
|
|
0
|
$self->yes_or_no( "may I try to install sudo?", timeout => 20 ) or do { |
2289
|
0
|
|
|
|
|
0
|
print "very well then, skipping along.\n"; |
2290
|
0
|
|
|
|
|
0
|
return ""; |
2291
|
|
|
|
|
|
|
}; |
2292
|
|
|
|
|
|
|
|
2293
|
0
|
0
|
|
|
|
0
|
-x $self->find_bin( "sudo", fatal => 0 ) or |
2294
|
|
|
|
|
|
|
$self->install_from_source( |
2295
|
|
|
|
|
|
|
package => 'sudo-1.6.9p17', |
2296
|
|
|
|
|
|
|
site => 'http://www.courtesan.com', |
2297
|
|
|
|
|
|
|
url => '/sudo/', |
2298
|
|
|
|
|
|
|
targets => [ './configure', 'make', 'make install' ], |
2299
|
|
|
|
|
|
|
patches => '', |
2300
|
|
|
|
|
|
|
debug => 1, |
2301
|
|
|
|
|
|
|
); |
2302
|
|
|
|
|
|
|
|
2303
|
|
|
|
|
|
|
# can we find it now? |
2304
|
0
|
|
|
|
|
0
|
$path_to_sudo = $self->find_bin( "sudo" ); |
2305
|
|
|
|
|
|
|
|
2306
|
0
|
0
|
|
|
|
0
|
if ( !-x $path_to_sudo ) { |
2307
|
0
|
|
|
|
|
0
|
print "sudo install failed!"; |
2308
|
0
|
|
|
|
|
0
|
return ''; |
2309
|
|
|
|
|
|
|
} |
2310
|
|
|
|
|
|
|
|
2311
|
0
|
|
|
|
|
0
|
return "$path_to_sudo -p 'Password for %u@%h:'"; |
2312
|
|
|
|
|
|
|
} |
2313
|
|
|
|
|
|
|
|
2314
|
|
|
|
|
|
|
sub syscmd { |
2315
|
10
|
|
|
10
|
1
|
8821
|
my $self = shift; |
2316
|
10
|
50
|
|
|
|
66
|
my $cmd = shift or die "missing command!\n"; |
2317
|
10
|
|
|
|
|
475
|
my %p = validate( |
2318
|
|
|
|
|
|
|
@_, |
2319
|
|
|
|
|
|
|
{ 'timeout' => { type => SCALAR, optional => 1 }, |
2320
|
|
|
|
|
|
|
%std_opts, |
2321
|
|
|
|
|
|
|
}, |
2322
|
|
|
|
|
|
|
); |
2323
|
|
|
|
|
|
|
|
2324
|
10
|
|
|
|
|
355
|
my %args = $log->get_std_args( %p ); |
2325
|
|
|
|
|
|
|
|
2326
|
10
|
|
|
|
|
110
|
$log->audit("syscmd: $cmd"); |
2327
|
|
|
|
|
|
|
|
2328
|
10
|
|
|
|
|
40
|
my ( $is_safe, $tainted, $bin, @args ); |
2329
|
|
|
|
|
|
|
|
2330
|
|
|
|
|
|
|
# separate the program from its arguments |
2331
|
10
|
50
|
|
|
|
183
|
if ( $cmd =~ m/\s+/xm ) { |
2332
|
10
|
|
|
|
|
187
|
($cmd) = $cmd =~ /^\s*(.*?)\s*$/; # trim lead/trailing whitespace |
2333
|
10
|
|
|
|
|
80
|
@args = split /\s+/, $cmd; # split on whitespace |
2334
|
10
|
|
|
|
|
35
|
$bin = shift @args; |
2335
|
10
|
|
|
|
|
22
|
$is_safe++; |
2336
|
10
|
|
|
|
|
167
|
$log->audit("\tprogram: $bin, args : " . join ' ', @args, %args); |
2337
|
|
|
|
|
|
|
} |
2338
|
|
|
|
|
|
|
else { |
2339
|
|
|
|
|
|
|
# does not not contain a ./ pattern |
2340
|
0
|
0
|
|
|
|
0
|
if ( $cmd !~ m{\./} ) { $bin = $cmd; $is_safe++; }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2341
|
|
|
|
|
|
|
} |
2342
|
|
|
|
|
|
|
|
2343
|
10
|
50
|
33
|
|
|
152
|
if ( $is_safe && !$bin ) { |
2344
|
0
|
|
|
|
|
0
|
return $log->error("command is not safe! BAILING OUT!", %args); |
2345
|
|
|
|
|
|
|
} |
2346
|
|
|
|
|
|
|
|
2347
|
10
|
|
|
|
|
19
|
my $message; |
2348
|
10
|
50
|
|
|
|
75
|
$message .= "syscmd: bin is <$bin>" if $bin; |
2349
|
10
|
50
|
|
|
|
42
|
$message .= " (safe)" if $is_safe; |
2350
|
10
|
|
|
|
|
49
|
$log->audit($message, %args ); |
2351
|
|
|
|
|
|
|
|
2352
|
10
|
100
|
66
|
|
|
359
|
if ( $bin && !-e $bin ) { # $bin is set, but we have not found it |
2353
|
5
|
50
|
|
|
|
76
|
$bin = $self->find_bin( $bin, fatal => 0, debug => 0 ) |
2354
|
|
|
|
|
|
|
or return $log->error( "$bin was not found", %args); |
2355
|
|
|
|
|
|
|
} |
2356
|
10
|
|
|
|
|
144
|
unshift @args, $bin; |
2357
|
|
|
|
|
|
|
|
2358
|
10
|
|
|
|
|
256
|
require Scalar::Util; |
2359
|
10
|
50
|
|
|
|
83
|
$tainted++ if Scalar::Util::tainted($cmd); |
2360
|
|
|
|
|
|
|
|
2361
|
10
|
|
|
|
|
147
|
my $before_path = $ENV{PATH}; |
2362
|
|
|
|
|
|
|
|
2363
|
|
|
|
|
|
|
# instead of croaking, maybe try setting a |
2364
|
|
|
|
|
|
|
# very restrictive PATH? I'll err on the side of safety |
2365
|
|
|
|
|
|
|
# $ENV{PATH} = ''; |
2366
|
10
|
50
|
33
|
|
|
74
|
return $log->error( "syscmd request has tainted data", %args) |
2367
|
|
|
|
|
|
|
if ( $tainted && !$is_safe ); |
2368
|
|
|
|
|
|
|
|
2369
|
10
|
50
|
|
|
|
50
|
if ($is_safe) { |
2370
|
10
|
|
|
|
|
752
|
my $prefix = "/usr/local"; # restrict the path |
2371
|
10
|
50
|
|
|
|
179
|
$prefix = "/opt/local" if -d "/opt/local"; |
2372
|
10
|
|
|
|
|
121
|
$ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin:$prefix/bin:$prefix/sbin"; |
2373
|
|
|
|
|
|
|
} |
2374
|
|
|
|
|
|
|
|
2375
|
10
|
|
|
|
|
22
|
my $r; |
2376
|
10
|
|
|
|
|
70
|
eval { |
2377
|
10
|
100
|
|
|
|
60
|
if ( defined $p{timeout} ) { |
2378
|
1
|
|
|
0
|
|
76
|
local $SIG{ALRM} = sub { die "alarm\n" }; |
|
0
|
|
|
|
|
0
|
|
2379
|
1
|
|
|
|
|
37
|
alarm $p{timeout}; |
2380
|
|
|
|
|
|
|
}; |
2381
|
|
|
|
|
|
|
#$r = system $cmd; |
2382
|
10
|
|
|
|
|
127247
|
$r = `$cmd 2>&1`; |
2383
|
10
|
100
|
|
|
|
324
|
alarm 0 if defined $p{timeout}; |
2384
|
|
|
|
|
|
|
}; |
2385
|
|
|
|
|
|
|
|
2386
|
10
|
50
|
|
|
|
72
|
if ($EVAL_ERROR) { |
2387
|
0
|
0
|
|
|
|
0
|
if ( $EVAL_ERROR eq "alarm\n" ) { |
2388
|
0
|
|
|
|
|
0
|
$log->audit("timed out"); |
2389
|
|
|
|
|
|
|
} |
2390
|
|
|
|
|
|
|
else { |
2391
|
0
|
|
|
|
|
0
|
return $log->error( "unknown error '$EVAL_ERROR'", %args); |
2392
|
|
|
|
|
|
|
} |
2393
|
|
|
|
|
|
|
} |
2394
|
10
|
|
|
|
|
212
|
$ENV{PATH} = $before_path; # set PATH back to original value |
2395
|
|
|
|
|
|
|
|
2396
|
10
|
|
|
|
|
250
|
my @caller = caller; |
2397
|
10
|
|
|
|
|
724
|
return $self->syscmd_exit_code( $r, $CHILD_ERROR, \@caller, \%args ); |
2398
|
|
|
|
|
|
|
} |
2399
|
|
|
|
|
|
|
|
2400
|
|
|
|
|
|
|
sub syscmd_exit_code { |
2401
|
10
|
|
|
10
|
0
|
55
|
my $self = shift; |
2402
|
10
|
|
|
|
|
109
|
my ($r, $err, $caller, $args) = @_; |
2403
|
|
|
|
|
|
|
|
2404
|
10
|
|
|
|
|
208
|
$log->audit( "r: $r" ); |
2405
|
|
|
|
|
|
|
|
2406
|
10
|
|
|
|
|
153
|
my $exit_code = sprintf ("%d", $err >> 8); |
2407
|
10
|
100
|
|
|
|
474
|
return 1 if $exit_code == 0; # success |
2408
|
|
|
|
|
|
|
|
2409
|
|
|
|
|
|
|
#print 'error # ' . $ERRNO . "\n"; # $! == $ERRNO |
2410
|
2
|
|
|
|
|
65
|
$log->error( "$err: $r",fatal=>0); |
2411
|
|
|
|
|
|
|
|
2412
|
2
|
50
|
|
|
|
42
|
if ( $err == -1 ) { # check $? for "normal" errors |
|
|
50
|
|
|
|
|
|
2413
|
0
|
|
|
|
|
0
|
$log->error( "failed to execute: $ERRNO", fatal=>0); |
2414
|
|
|
|
|
|
|
} |
2415
|
|
|
|
|
|
|
elsif ( $err & 127 ) { # check for core dump |
2416
|
0
|
0
|
|
|
|
0
|
printf "child died with signal %d, %s coredump\n", ( $? & 127 ), |
2417
|
|
|
|
|
|
|
( $? & 128 ) ? 'with' : 'without'; |
2418
|
|
|
|
|
|
|
} |
2419
|
|
|
|
|
|
|
|
2420
|
2
|
|
|
|
|
48
|
return $log->error( "$err: $r", location => join( ", ", @$caller ), %$args ); |
2421
|
|
|
|
|
|
|
}; |
2422
|
|
|
|
|
|
|
|
2423
|
|
|
|
|
|
|
sub yes_or_no { |
2424
|
1
|
|
|
1
|
1
|
12
|
my $self = shift; |
2425
|
1
|
|
|
|
|
12
|
my $question = shift; |
2426
|
1
|
|
|
|
|
50
|
my %p = validate( |
2427
|
|
|
|
|
|
|
@_, |
2428
|
|
|
|
|
|
|
{ 'timeout' => { type => SCALAR, optional => 1 }, |
2429
|
|
|
|
|
|
|
'force' => { type => BOOLEAN, optional => 1, default => 0 }, |
2430
|
|
|
|
|
|
|
%std_opts |
2431
|
|
|
|
|
|
|
}, |
2432
|
|
|
|
|
|
|
); |
2433
|
|
|
|
|
|
|
|
2434
|
|
|
|
|
|
|
|
2435
|
|
|
|
|
|
|
# for 'make test' testing |
2436
|
1
|
50
|
|
|
|
27
|
return 1 if $question eq "test"; |
2437
|
|
|
|
|
|
|
|
2438
|
|
|
|
|
|
|
# force if interactivity testing is not working properly. |
2439
|
0
|
0
|
0
|
|
|
|
if ( !$p{force} && !$self->is_interactive ) { |
2440
|
0
|
|
|
|
|
|
carp "not running interactively, can't prompt!"; |
2441
|
0
|
|
|
|
|
|
return; |
2442
|
|
|
|
|
|
|
} |
2443
|
|
|
|
|
|
|
|
2444
|
0
|
|
|
|
|
|
my $response; |
2445
|
|
|
|
|
|
|
|
2446
|
0
|
0
|
|
|
|
|
print "\nYou have $p{timeout} seconds to respond.\n" if $p{timeout}; |
2447
|
0
|
|
|
|
|
|
print "\n\t\t$question"; |
2448
|
|
|
|
|
|
|
|
2449
|
|
|
|
|
|
|
# I wish I knew why this is not working correctly |
2450
|
|
|
|
|
|
|
# eval { local $SIG{__DIE__}; require Term::ReadKey }; |
2451
|
|
|
|
|
|
|
# if ($@) { # |
2452
|
|
|
|
|
|
|
# require Term::ReadKey; |
2453
|
|
|
|
|
|
|
# Term::ReadKey->import(); |
2454
|
|
|
|
|
|
|
# print "yay, Term::ReadKey is present! Are you pleased? (y/n):\n"; |
2455
|
|
|
|
|
|
|
# use Term::Readkey; |
2456
|
|
|
|
|
|
|
# ReadMode 4; |
2457
|
|
|
|
|
|
|
# while ( not defined ($key = ReadKey(-1))) |
2458
|
|
|
|
|
|
|
# { # no key yet } |
2459
|
|
|
|
|
|
|
# print "Got key $key\n"; |
2460
|
|
|
|
|
|
|
# ReadMode 0; |
2461
|
|
|
|
|
|
|
# }; |
2462
|
|
|
|
|
|
|
|
2463
|
0
|
0
|
|
|
|
|
if ( $p{timeout} ) { |
2464
|
0
|
|
|
|
|
|
eval { |
2465
|
0
|
|
|
0
|
|
|
local $SIG{ALRM} = sub { die "alarm\n" }; |
|
0
|
|
|
|
|
|
|
2466
|
0
|
|
|
|
|
|
alarm $p{timeout}; |
2467
|
0
|
|
0
|
|
|
|
do { |
2468
|
0
|
|
|
|
|
|
print "(y/n): "; |
2469
|
0
|
|
|
|
|
|
$response = lc(); |
2470
|
0
|
|
|
|
|
|
chomp($response); |
2471
|
|
|
|
|
|
|
} until ( $response eq "n" || $response eq "y" ); |
2472
|
0
|
|
|
|
|
|
alarm 0; |
2473
|
|
|
|
|
|
|
}; |
2474
|
|
|
|
|
|
|
|
2475
|
0
|
0
|
|
|
|
|
if ($@) { |
2476
|
0
|
0
|
|
|
|
|
$@ eq "alarm\n" ? print "timed out!\n" : carp; |
2477
|
|
|
|
|
|
|
} |
2478
|
|
|
|
|
|
|
|
2479
|
0
|
0
|
0
|
|
|
|
return ($response && $response eq "y") ? 1 : 0; |
2480
|
|
|
|
|
|
|
} |
2481
|
|
|
|
|
|
|
|
2482
|
0
|
|
0
|
|
|
|
do { |
2483
|
0
|
|
|
|
|
|
print "(y/n): "; |
2484
|
0
|
|
|
|
|
|
$response = lc(); |
2485
|
0
|
|
|
|
|
|
chomp($response); |
2486
|
|
|
|
|
|
|
} until ( $response eq "n" || $response eq "y" ); |
2487
|
|
|
|
|
|
|
|
2488
|
0
|
0
|
|
|
|
|
return ($response eq "y") ? 1 : 0; |
2489
|
|
|
|
|
|
|
} |
2490
|
|
|
|
|
|
|
|
2491
|
|
|
|
|
|
|
1; |
2492
|
|
|
|
|
|
|
__END__ |