File Coverage

lib/Apache/Logmonster/Utility.pm
Criterion Covered Total %
statement 614 1188 51.6
branch 215 716 30.0
condition 40 172 23.2
subroutine 64 91 70.3
pod 37 67 55.2
total 970 2234 43.4


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__