File Coverage

lib/Mail/Toaster/Utility.pm
Criterion Covered Total %
statement 576 1135 50.7
branch 202 694 29.1
condition 34 154 22.0
subroutine 65 91 71.4
pod 36 60 60.0
total 913 2134 42.7


line stmt bran cond sub pod time code
1             package Mail::Toaster::Utility;
2             # ABSTRACT: utility subroutines for sysadmin tasks
3              
4 11     11   2183 use strict;
  11         54  
  11         295  
5 11     11   36 use warnings;
  11         14  
  11         434  
6              
7             our $VERSION = '5.51';
8              
9 11     11   43 use Cwd;
  11         15  
  11         662  
10 11     11   62 use Carp;
  11         15  
  11         544  
11             #use Data::Dumper;
12 11     11   42 use English qw( -no_match_vars );
  11         11  
  11         85  
13 11     11   3635 use File::Basename;
  11         12  
  11         685  
14 11     11   3603 use File::Copy;
  11         13245  
  11         496  
15 11     11   67 use File::Path;
  11         14  
  11         452  
16 11     11   34 use File::Spec;
  11         10  
  11         141  
17 11     11   1767 use File::stat;
  11         18977  
  11         64  
18 11     11   899 use Params::Validate qw(:all);
  11         6249  
  11         1578  
19 11     11   45 use Scalar::Util qw( openhandle );
  11         14  
  11         475  
20             #use URI; # required in get_url
21              
22 11     11   42 use lib 'lib';
  11         23  
  11         81  
23 11     11   1708 use parent 'Mail::Toaster::Base';
  11         427  
  11         66  
24              
25             sub ask {
26 0     0 1 0 my $self = shift;
27 0         0 my $question = shift;
28 0         0 my %p = validate(
29             @_,
30             { default => { type => SCALAR|UNDEF, optional => 1 },
31             timeout => { type => SCALAR, optional => 1 },
32             password => { type => BOOLEAN, optional => 1, default => 0 },
33             test_ok => { type => BOOLEAN, optional => 1 },
34             }
35             );
36              
37 0         0 my $pass = $p{password};
38 0         0 my $default = $p{default};
39              
40 0 0       0 if ( ! $self->is_interactive() ) {
41 0         0 $self->audit( "not running interactively, can not prompt!");
42 0         0 return $default;
43             }
44              
45 0 0       0 return $self->error( "ask called with \'$question\' which looks unsafe." )
46 11     11   6986 if $question !~ m{\A \p{Any}* \z}xms;
  11         84  
  11         129  
47              
48 0         0 my $response;
49              
50 0 0       0 return $p{test_ok} if defined $p{test_ok};
51              
52 0         0 PROMPT:
53             print "Please enter $question";
54 0 0 0     0 print " [$default]" if ( $default && !$pass );
55 0         0 print ": ";
56              
57 0 0       0 system "stty -echo" if $pass;
58              
59 0 0       0 if ( $p{timeout} ) {
60 0         0 eval {
61 0     0   0 local $SIG{ALRM} = sub { die "alarm\n" };
  0         0  
62 0         0 alarm $p{timeout};
63 0         0 $response = <STDIN>;
64 0         0 alarm 0;
65             };
66 0 0       0 if ($EVAL_ERROR) {
67 0 0       0 $EVAL_ERROR eq "alarm\n" ? print "timed out!\n" : warn;
68             }
69             }
70             else {
71 0         0 $response = <STDIN>;
72             }
73              
74 0 0       0 if ( $pass ) {
75 0         0 print "Please enter $question (confirm): ";
76 0         0 my $response2 = <STDIN>;
77 0 0       0 unless ( $response eq $response2 ) {
78 0         0 print "\nPasswords don't match, try again.\n";
79 0         0 goto PROMPT;
80             }
81 0         0 system "stty echo";
82 0         0 print "\n";
83             }
84              
85 0         0 chomp $response;
86              
87 0 0       0 return $response if $response; # if they typed something, return it
88 0 0       0 return $default if $default; # return the default, if available
89 0         0 return ''; # return empty handed
90             }
91              
92             sub archive_file {
93 5     5 1 21612 my $self = shift;
94 5 50       27 my $file = shift or return $self->error("missing filename in request");
95 5         47 my %p = validate( @_,
96             { 'sudo' => { type => BOOLEAN, optional => 1, default => 1 },
97             'mode' => { type => SCALAR, optional => 1 },
98             destdir => { type => SCALAR, optional => 1 },
99             $self->get_std_opts,
100             }
101             );
102              
103 5         34 my %args = $self->get_std_args( %p );
104              
105 5 100       165 return $self->error( "file ($file) is missing!", %args )
106             if !-e $file;
107              
108 4         24 my $archive = $file . '.' . time;
109              
110 4 50 33     14 if ( $p{destdir} && -d $p{destdir} ) {
111 0         0 my ($vol,$dirs,$file_wo_path) = File::Spec->splitpath( $archive );
112 0         0 $archive = File::Spec->catfile( $p{destdir}, $file_wo_path );
113             };
114              
115             # see if we can write to both files (new & archive) with current user
116 4 50 33     20 if ( $self->is_writable( $file, %args )
117             && $self->is_writable( $archive, %args ) ) {
118              
119             # we have permission, use perl's native copy
120 4         18 copy( $file, $archive );
121 4 50       1096 if ( -e $archive ) {
122 4         30 $self->audit("archive_file: $file backed up to $archive");
123 4 50       13 $self->chmod( file => $file, mode => $p{mode}, %args ) if $p{mode};
124 4         21 return $archive;
125             };
126             }
127              
128             # we failed with existing permissions, try to escalate
129 0 0 0     0 $self->archive_file_sudo( $file ) if ( $p{sudo} && $< != 0 );
130              
131 0 0       0 return $self->error( "backup of $file to $archive failed: $!", %args)
132             if ! -e $archive;
133              
134 0 0       0 $self->chmod( file => $file, mode => $p{mode}, %args ) if $p{mode};
135              
136 0         0 $self->audit("$file backed up to $archive");
137 0         0 return $archive;
138             }
139              
140             sub archive_file_sudo {
141 0     0 0 0 my $self = shift;
142 0         0 my ($file, $archive) = @_;
143              
144 0         0 my $sudo = $self->sudo();
145 0         0 my $cp = $self->find_bin( 'cp',fatal=>0 );
146              
147 0 0 0     0 if ( $sudo && $cp ) {
148 0         0 return $self->syscmd( "$sudo $cp $file $archive",fatal=>0 );
149             }
150 0         0 $self->error( "archive_file: sudo or cp was missing, could not escalate.",fatal=>0);
151 0         0 return;
152             };
153              
154             sub chmod {
155 3     3 1 711 my $self = shift;
156 3         29 my %p = validate(
157             @_,
158             { 'file' => { type => SCALAR, optional => 1, },
159             'file_or_dir' => { type => SCALAR, optional => 1, },
160             'dir' => { type => SCALAR, optional => 1, },
161             'mode' => { type => SCALAR, optional => 0, },
162             'sudo' => { type => BOOLEAN, optional => 1, default => 0 },
163             $self->get_std_opts,
164             }
165             );
166              
167 3         20 my $mode = $p{mode};
168 3         10 my %args = $self->get_std_args( %p );
169              
170             my $file = $p{file} || $p{file_or_dir} || $p{dir}
171 3 50 33     24 or return $self->error( "invalid params to chmod in ". ref $self );
172              
173 3 50       10 if ( $p{sudo} ) {
174 0         0 my $chmod = $self->find_bin( 'chmod', verbose => 0 );
175 0         0 my $sudo = $self->sudo();
176 0 0       0 $self->syscmd( "$sudo $chmod $mode $file", verbose => 0 )
177             or return $self->error( "couldn't chmod $file: $!", %args );
178             }
179              
180             # note the conversion of ($mode) to an octal value. Very important!
181 3 50       87 CORE::chmod( oct($mode), $file ) or
182             return $self->error( "couldn't chmod $file: $!", %args);
183              
184 3         14 $self->audit("chmod $mode $file");
185             }
186              
187             sub chown {
188 3     3 1 4030 my $self = shift;
189 3         7 my $file = shift;
190 3         28 my %p = validate( @_,
191             { 'uid' => { type => SCALAR },
192             'gid' => { type => SCALAR },
193             'sudo' => { type => BOOLEAN, optional => 1 },
194             $self->get_std_opts,
195             }
196             );
197              
198 3         25 my %args = $self->get_std_args( %p );
199 3         12 my ( $uid, $gid, $sudo ) = ( $p{uid}, $p{gid}, $p{sudo} );
200              
201 3 50       8 $file or return $self->error( "missing file or dir", %args );
202 3 50       51 return $self->error( "file $file does not exist!", %args ) if ! -e $file;
203              
204 3         19 $self->audit("chown: preparing to chown $uid $file");
205              
206             # sudo forces system chown instead of the perl builtin
207 3 50       7 return $self->chown_system( $file,
208             %args,
209             user => $uid,
210             group => $gid,
211             ) if $sudo;
212              
213 3         6 my ( $nuid, $ngid ); # if uid or gid is not numeric, convert it
214              
215 3 50       19 if ( $uid =~ /\A[0-9]+\z/ ) {
216 0         0 $nuid = int($uid);
217 0         0 $self->audit(" using $nuid from int($uid)");
218             }
219             else {
220 3         149 $nuid = getpwnam($uid);
221 3 100       21 return $self->error( "failed to get uid for $uid", %args) if ! defined $nuid;
222 2         24 $self->audit(" converted $uid to a number: $nuid");
223             }
224              
225 2 50       12 if ( $gid =~ /\A[0-9\-]+\z/ ) {
226 0         0 $ngid = int( $gid );
227 0         0 $self->audit(" using $ngid from int($gid)");
228             }
229             else {
230 2         88 $ngid = getgrnam( $gid );
231 2 50       9 return $self->error( "failed to get gid for $gid", %args) if ! defined $ngid;
232 2         14 $self->audit(" converted $gid to numeric: $ngid");
233             }
234              
235 2 50       72 chown( $nuid, $ngid, $file )
236             or return $self->error( "couldn't chown $file: $!",%args);
237              
238 2         18 return 1;
239             }
240              
241             sub chown_system {
242 1     1 1 27 my $self = shift;
243 1         5 my $dir = shift;
244 1         21 my %p = validate( @_,
245             { 'user' => { type => SCALAR, optional => 0, },
246             'group' => { type => SCALAR, optional => 1, },
247             'recurse' => { type => BOOLEAN, optional => 1, },
248             $self->get_std_opts,
249             }
250             );
251              
252 1         9 my ( $user, $group, $recurse ) = ( $p{user}, $p{group}, $p{recurse} );
253 1         5 my %args = $self->get_std_args( %p );
254              
255 1 50       8 $dir or return $self->error( "missing file or dir", %args );
256 1         5 my $cmd = $self->find_bin( 'chown', %args );
257              
258 1 50       8 $cmd .= " -R" if $recurse;
259 1         4 $cmd .= " $user";
260 1 50       5 $cmd .= ":$group" if $group;
261 1         3 $cmd .= " $dir";
262              
263 1         7 $self->audit( "cmd: $cmd" );
264              
265 1 50       9 $self->syscmd( $cmd, %args ) or
266             return $self->error( "couldn't chown with $cmd: $!", %args);
267              
268 1         6 my $mess;
269 1 50       16 $mess .= "Recursively " if $recurse;
270 1         6 $mess .= "changed $dir to be owned by $user";
271 1         6 $self->audit( $mess );
272              
273 1         17 return 1;
274             }
275              
276             sub clean_tmp_dir {
277 2     2 1 378 my $self = shift;
278 2 50       12 my $dir = shift or die "missing dir name";
279 2         11 my %p = validate( @_, { $self->get_std_opts } );
280              
281 2         12 my %args = $self->get_std_args( %p );
282              
283 2         5265 my $before = cwd; # remember where we started
284              
285 2 50       61 return $self->error( "couldn't chdir to $dir: $!", %args) if !chdir $dir;
286              
287 2         25 foreach ( $self->get_dir_files( $dir ) ) {
288 4 50       14 next unless $_;
289              
290 4         37 my ($file) = $_ =~ /^(.*)$/;
291              
292 4         27 $self->audit( "deleting file $file" );
293              
294 4 100       102 if ( -f $file ) {
    50          
295 3 50       173 unlink $file or
296             $self->file_delete( $file, %args );
297             }
298             elsif ( -d $file ) {
299 1 50       395 rmtree $file or return $self->error( "couldn't delete $file", %args);
300             }
301             else {
302 0         0 $self->audit( "Cannot delete unknown entity: $file" );
303             }
304             }
305              
306 2         26 chdir $before;
307 2         33 return 1;
308             }
309              
310             sub cwd_source_dir {
311 2     2 1 7 my $self = shift;
312 2 50       5 my $dir = shift or die "missing dir in request\n";
313 2         11 my %p = validate( @_,
314             { 'src' => { type => SCALAR, optional => 1, },
315             'sudo' => { type => BOOLEAN, optional => 1, },
316             $self->get_std_opts,
317             }
318             );
319              
320 2         9 my ( $src, $sudo, ) = ( $p{src}, $p{sudo}, );
321 2         5 my %args = $self->get_std_args( %p );
322              
323 2 50 66     44 return $self->error( "Something (other than a directory) is at $dir and " .
324             "that's my build directory. Please remove it and try again!", %args )
325             if ( -e $dir && !-d $dir );
326              
327 2 100       17 if ( !-d $dir ) {
328              
329 1         6 $self->_try_mkdir( $dir ); # use the perl builtin mkdir
330              
331 1 50       15 if ( !-d $dir ) {
332 0         0 $self->audit( "trying again with system mkdir...");
333 0         0 $self->mkdir_system( dir => $dir, %args);
334              
335 0 0       0 if ( !-d $dir ) {
336 0         0 $self->audit( "trying one last time with $sudo mkdir -p....");
337 0 0       0 $self->mkdir_system( dir => $dir, sudo => 1, %args)
338             or return $self->error("Couldn't create $dir.", %args);
339             }
340             }
341             }
342              
343 2 50       26 chdir $dir or return $self->error( "failed to cd to $dir: $!", %args);
344 2         11 return 1;
345             }
346              
347             sub _try_mkdir {
348 1     1   2 my ($self, $dir ) = @_;
349 1 50       202 mkpath( $dir, 0, oct('0755') )
350             or return $self->error( "mkdir $dir failed: $!");
351 1         5 $self->audit( "created $dir");
352 1         6 return 1;
353             }
354              
355             sub extract_archive {
356 2     2 1 5 my $self = shift;
357 2 50       11 my $archive = shift or die "missing archive name";
358 2         25 my %p = validate( @_, { $self->get_std_opts } );
359 2         19 my %args = $self->get_std_args( %p );
360              
361 2         4 my $r;
362 2         25 my %types = (
363             gz => { bin => 'gunzip', content => 'gzip', },
364             bz2 => { bin => 'bunzip2', content => 'b(un)?zip2', }, # BSD bunzip2, Linux bzip2
365             xz => { bin => 'xz', content => 'xz', },
366             );
367              
368 2 100       82 if ( !-e $archive ) {
369 1         7 foreach my $ext ( keys %types, map { 'tar.' . $_ } keys %types ) {
  3         8  
370 6 50       134 next if ! -e "$archive.$ext";
371 0         0 $archive = "$archive.$ext";
372 0         0 last;
373             };
374             }
375 2 100       86 return $self->error( "file $archive is missing!", %args ) if ! -e $archive;
376              
377 1         7 $self->audit("found $archive");
378              
379 1 0       21 my $type
    50          
    50          
380             = $archive =~ /bz2$/ ? 'bz2'
381             : $archive =~ /gz$/ ? 'gz'
382             : $archive =~ /xz$/ ? 'xz'
383             : return $self->error( 'unknown archive type', %args);
384              
385             # find binaries to inspect and expand the archive
386 1         12 my $tar = $self->find_bin( 'tar', %args );
387 1         9 my $file = $self->find_bin( 'file', %args );
388              
389             # make sure the archive contents match the file extension
390 1         7 $ENV{PATH} = '/bin:/usr/bin'; # prevent taint checks from barfing on ``
391 1 50       42753 return $self->error( "$archive not a $type compressed file", %args)
392             unless grep ( /$types{$type}{content}/, `$file $archive` );
393              
394 1         38 my $bin = $self->find_bin( $types{$type}{bin}, %args);
395              
396 1 50       15 $self->syscmd( "$bin -c $archive | $tar -xf -" ) or return;
397              
398 1         14 $self->audit( "extracted $archive" );
399 1         33 return 1;
400             }
401              
402             sub file_delete {
403 6     6 1 234 my $self = shift;
404 6 50       20 my $file = shift or die "missing file argument";
405 6         38 my %p = validate( @_,
406             { 'sudo' => { type => BOOLEAN, optional => 1, default => 0 },
407             $self->get_std_opts,
408             }
409             );
410              
411 6         35 my %args = $self->get_std_args( %p );
412              
413 6 100       157 return $self->error( "$file does not exist", %args ) if !-e $file;
414              
415 5 50       51 if ( -w $file ) {
416 5         23 $self->audit( "write permission to $file: ok" );
417              
418 5 50       393 unlink $file or return $self->error( "failed to delete $file", %args );
419              
420 5         38 $self->audit( "deleted: $file" );
421 5         33 return 1;
422             }
423              
424 0 0       0 if ( !$p{sudo} ) { # all done
425 0 0       0 return -e $file ? undef : 1;
426             }
427              
428 0         0 my $err = "trying with system rm";
429 0         0 my $rm_command = $self->find_bin( "rm", %args );
430 0         0 $rm_command .= " -f $file";
431              
432 0 0       0 if ( $< != 0 ) { # we're not running as root
433 0         0 my $sudo = $self->sudo( %args );
434 0         0 $rm_command = "$sudo $rm_command";
435 0         0 $err .= " (sudo)";
436             }
437              
438 0 0       0 $self->syscmd( $rm_command, %args )
439             or return $self->error( $err, %args );
440              
441 0 0       0 return -e $file ? 0 : 1;
442             }
443              
444             sub file_is_newer {
445 2     2 1 3 my $self = shift;
446 2         12 my %p = validate( @_,
447             { f1 => { type => SCALAR },
448             f2 => { type => SCALAR },
449             $self->get_std_opts,
450             }
451             );
452              
453 2         10 my ( $file1, $file2 ) = ( $p{f1}, $p{f2} );
454              
455             # get file attributes via stat
456             # (dev,ino,mode,nlink,uid,gid,rdev,size,atime,mtime,ctime,blksize,blocks)
457              
458 2         10 $self->audit( "checking age of $file1 and $file2" );
459              
460 2         12 my $stat1 = stat($file1)->mtime;
461 2         313 my $stat2 = stat($file2)->mtime;
462              
463 2         202 $self->audit( "timestamps are $stat1 and $stat2");
464              
465 2 100       17 return 1 if ( $stat2 > $stat1 );
466 1         5 return;
467              
468             # I could just:
469             #
470             # if ( stat($f1)[9] > stat($f2)[9] )
471             #
472             # but that forces the reader to read the man page for stat
473             # to see what's happening
474             }
475              
476             sub file_read {
477 11     11 1 28 my $self = shift;
478 11 50       47 my $file = shift or return $self->error("missing filename in request");
479 11         242 my %p = validate(
480             @_,
481             { 'max_lines' => { type => SCALAR, optional => 1 },
482             'max_length' => { type => SCALAR, optional => 1 },
483             $self->get_std_opts
484             }
485             );
486              
487 11         66 my ( $max_lines, $max_length ) = ( $p{max_lines}, $p{max_length} );
488 11         57 my %args = $self->get_std_args( %p );
489              
490 11 50       275 return $self->error( "$file does not exist!", %args) if !-e $file;
491 11 50       145 return $self->error( "$file is not readable", %args ) if !-r $file;
492              
493 11 50       494 open my $FILE, '<', $file or
494             return $self->error( "could not open $file: $OS_ERROR", %args );
495              
496 11         58 my ( $line, @lines );
497              
498 11 50       45 if ( ! $max_lines) {
499 11         2293 chomp( @lines = <$FILE> );
500 11         194 close $FILE;
501 11         540 return @lines;
502             # TODO: make max_length work with slurp mode, without doing something ugly like
503             # reading in the entire line and then truncating it.
504             };
505              
506 0         0 my $i = 0;
507 0         0 while ( $i < $max_lines ) {
508 0 0       0 if ($max_length) { $line = substr <$FILE>, 0, $max_length; }
  0         0  
509 0         0 else { $line = <$FILE>; };
510 0 0       0 last if ! $line;
511 0 0       0 last if eof $FILE;
512 0         0 push @lines, $line;
513 0         0 $i++;
514             }
515 0         0 chomp @lines;
516 0         0 close $FILE;
517 0         0 return @lines;
518             }
519              
520             sub file_mode {
521 1     1 1 2 my $self = shift;
522 1         4 my %p = validate( @_,
523             { 'file' => { type => SCALAR },
524             $self->get_std_opts
525             }
526             );
527              
528 1         5 my $file = $p{file};
529 1         4 my %args = $self->get_std_args( %p );
530              
531 1 50       31 return $self->error( "file '$file' does not exist!", %args)
532             if !-e $file;
533              
534             # one way to get file mode (using File::mode)
535             # my $raw_mode = stat($file)->[2];
536             ## no critic
537 1         6 my $mode = sprintf "%04o", stat($file)->[2] & 07777;
538              
539             # another way to get it
540             # my $st = stat($file);
541             # my $mode = sprintf "%lo", $st->mode & 07777;
542              
543 1         130 $self->audit( "file $file has mode: $mode" );
544 1         4 return $mode;
545             }
546              
547             sub file_write {
548 10     10 1 544 my $self = shift;
549 10 50       32 my $file = shift or return $self->error("missing filename in request");
550 10         87 my %p = validate(
551             @_,
552             { 'lines' => { type => ARRAYREF },
553             'append' => { type => BOOLEAN, optional => 1, default => 0 },
554             'mode' => { type => SCALAR, optional => 1 },
555             $self->get_std_opts
556             }
557             );
558              
559 10         67 my $append = $p{append};
560 10         14 my $lines = $p{lines};
561 10         38 my %args = $self->get_std_args( %p );
562              
563 10 50       281 return $self->error( "oops, $file is a directory", %args) if -d $file;
564 10 50       52 return $self->error( "oops, $file is not writable", %args )
565             if ( ! $self->is_writable( $file, %args) );
566              
567 10         22 my $m = "wrote";
568 10         11 my $write_mode = '>'; # (over)write
569              
570 10 100       18 if ( $append ) {
571 3         5 $m = "appended";
572 3         5 $write_mode = '>>';
573 3 50       41 if ( -f $file ) {
574 3 50       20 copy $file, "$file.tmp" or return $self->error(
575             "couldn't create $file.tmp for safe append", %args );
576             };
577             };
578              
579 10 100       1659 open my $HANDLE, $write_mode, "$file.tmp"
580             or return $self->error( "file_write: couldn't open $file: $!", %args );
581              
582 9         15 my $c = 0;
583 9         25 foreach ( @$lines ) { chomp; print $HANDLE "$_\n"; $c++ };
  9         19  
  9         71  
  9         19  
584 9 50       285 close $HANDLE or return $self->error( "couldn't close $file: $!", %args );
585              
586 9         84 $self->audit( "file_write: $m $c lines to $file", %args );
587              
588 9 50       60 move( "$file.tmp", $file )
589             or return $self->error(" unable to update $file", %args);
590              
591             # set file permissions mode if requested
592             $self->chmod( file => $file, mode => $p{mode}, %args )
593 9 50 0     973 or return if $p{mode};
594              
595 9         80 return 1;
596             }
597              
598             sub files_diff {
599 5     5 1 17 my $self = shift;
600 5         40 my %p = validate(
601             @_,
602             { f1 => { type => SCALAR },
603             f2 => { type => SCALAR },
604             type => { type => SCALAR, optional => 1, default => 'text' },
605             $self->get_std_opts,
606             }
607             );
608              
609 5         36 my ( $f1, $f2, $type ) = ( $p{f1}, $p{f2}, $p{type} );
610 5         17 my %args = $self->get_std_args(%p);
611              
612 5 50 33     184 if ( !-e $f1 || !-e $f2 ) {
613 0         0 $self->error( "$f1 or $f2 does not exist!", %args );
614 0         0 return -1;
615             };
616              
617 5 100       23 return $self->files_diff_md5( $f1, $f2, \%args)
618             if $type ne "text";
619              
620             ### TODO
621             # use file here to make sure files are ASCII
622             #
623 3         20 $self->audit("comparing ascii files $f1 and $f2 using diff", %args);
624              
625 3         16 my $diff = $self->find_bin( 'diff', %args );
626 3         7832 my $r = `$diff $f1 $f2`;
627 3         14 chomp $r;
628 3         209 return $r;
629             };
630              
631             sub files_diff_md5 {
632 2     2 0 5 my $self = shift;
633 2         4 my ($f1, $f2, $args) = @_;
634              
635 2         17 $self->audit("comparing $f1 and $f2 using md5", %$args);
636              
637 2         4 eval { require Digest::MD5 };
  2         21  
638 2 50       7 return $self->error( "couldn't load Digest::MD5!", %$args )
639             if $EVAL_ERROR;
640              
641 2         7 $self->audit( "\t Digest::MD5 loaded", %$args );
642              
643 2         4 my @md5sums;
644              
645 2         15 foreach my $f ( $f1, $f2 ) {
646 4         5 my ( $sum, $changed );
647              
648             # if the md5 file exists
649 4 100       82 if ( -f "$f.md5" ) {
650 2         15 $sum = $self->file_read( "$f.md5", %$args );
651 2         13 $self->audit( " md5 file for $f exists", %$args );
652             }
653              
654             # if the md5 file is missing, invalid, or older than the file, recompute it
655 4 100 66     107 if ( ! -f "$f.md5" or $sum !~ /[0-9a-f]+/i or
      100        
656             $self->file_is_newer( f1 => "$f.md5", f2 => $f, %$args )
657             )
658             {
659 3         32 my $ctx = Digest::MD5->new;
660 3         91 open my $FILE, '<', $f;
661 3         64 $ctx->addfile(*$FILE);
662 3         16 $sum = $ctx->hexdigest;
663 3         20 close $FILE;
664 3         20 $changed++;
665 3         26 $self->audit(" calculated md5: $sum", %$args);
666             }
667              
668 4         8 push( @md5sums, $sum );
669 4 100       22 $self->file_write( "$f.md5", lines => [$sum], %$args ) if $changed;
670             }
671              
672 2 100       14 return if $md5sums[0] eq $md5sums[1];
673 1         8 return 1;
674             }
675              
676             sub find_bin {
677 39     39 1 3094 my $self = shift;
678 39 50       141 my $bin = shift or die "missing argument to find_bin\n";
679 39         242 my %p = validate( @_,
680             { 'dir' => { type => SCALAR, optional => 1, },
681             $self->get_std_opts,
682             },
683             );
684              
685 39         185 my $prefix = "/usr/local";
686 39         145 my %args = $self->get_std_args(%p);
687              
688 39 50 33     241 if ( $bin =~ /^\// && -x $bin ) { # we got a full path
689 0         0 $self->audit( "find_bin: found $bin", %args );
690 0         0 return $bin;
691             };
692              
693 39         60 my @prefixes;
694 39 50       108 push @prefixes, $p{dir} if $p{dir};
695 39         205 push @prefixes, qw"
696             /usr/local/bin /usr/local/sbin/ /opt/local/bin /opt/local/sbin
697             $prefix/mysql/bin /bin /usr/bin /sbin /usr/sbin
698             ";
699 39         91126 push @prefixes, cwd;
700              
701 39         182 my $found;
702 39         185 foreach my $prefix ( @prefixes ) {
703 251 100       3338 if ( -x "$prefix/$bin" ) {
704 36 50       221 $found = "$prefix/$bin" and last;
705             };
706             };
707              
708 39 100       164 if ($found) {
709 36         618 $self->audit( "find_bin: found $found", %args);
710 36         444 return $found;
711             }
712              
713 3         81 return $self->error( "find_bin: could not find $bin", %args);
714             }
715              
716             sub find_config {
717 11     11 1 391 my $self = shift;
718 11 50       38 my $file = shift or die "missing file name";
719 11         60 my %p = validate( @_,
720             { etcdir => { type => SCALAR | UNDEF, optional => 1, },
721             $self->get_std_opts,
722             }
723             );
724              
725 11 50       68 if ( $p{verbose} > 1 ) {
726 0         0 my @caller = caller;
727 0         0 $self->audit( sprintf("find_config loaded by %s, %s, %s\n", @caller ));
728             };
729              
730 11         67 $self->audit("find_config: searching for $file");
731              
732 11         11 my @etc_dirs;
733 11         22 my $etcdir = $p{etcdir};
734 11 100 66     73 push @etc_dirs, $etcdir if ( $etcdir && -d $etcdir );
735 11         27 push @etc_dirs, qw{ /opt/local/etc /usr/local/etc /etc etc };
736 11         25098 push @etc_dirs, cwd;
737              
738 11         149 my $r = $self->find_readable( $file, @etc_dirs );
739 11 100       46 if ( $r ) {
740 2         20 $self->audit( " found $r" );
741 2         35 return $r;
742             };
743              
744             # try $file-dist in the working dir
745 9 100       132 if ( -r "./$file-dist" ) {
746 7         89 $self->audit(" found in ./");
747 7         12639 return cwd . "/$file-dist";
748             }
749              
750 2         43 return $self->error( "could not find $file", fatal => $p{fatal} );
751             }
752              
753             sub find_readable {
754 58     58 0 82 my $self = shift;
755 58         80 my $file = shift;
756 58 100       189 my $dir = shift or return; # break recursion at end of @_
757              
758             #$self->audit("looking for $file in $dir") if $self->{verbose};
759 49 100       962 if ( -r "$dir/$file" ) {
760 11     11   185842 no warnings;
  11         17  
  11         41062  
761 2         8 return "$dir/$file"; # success
762             }
763              
764 47 100       370 if ( ! -d $dir ) {
765 19         220 return $self->find_readable( $file, @_ );
766             };
767              
768             # warn about directories we don't have read access to
769 28 50       272 if ( ! -r $dir ) {
770 0         0 $self->error( "$dir is not readable", fatal => 0 );
771 0         0 return $self->find_readable( $file, @_ );
772             };
773              
774             # warn about files that exist but aren't readable
775 28 50       285 if ( -e "$dir/$file" ) {
776 0         0 $self->error( "$dir/$file is not readable", fatal => 0);
777             };
778              
779 28         253 return $self->find_readable( $file, @_ );
780             }
781              
782             sub fstab_list {
783 1     1 1 4 my $self = shift;
784 1         10 my %p = validate( @_, { $self->get_std_opts, } );
785              
786 1 50       11 if ( $OSNAME eq "darwin" ) {
787 0         0 return ['fstab not used on Darwin!'];
788             }
789              
790 1         3 my $fstab = "/etc/fstab";
791 1 50       48 if ( !-e $fstab ) {
792 0 0       0 print "fstab_list: FAILURE: $fstab does not exist!\n" if $p{verbose};
793 0         0 return;
794             }
795              
796 1         7 my $grep = $self->find_bin( "grep", verbose => 0 );
797 1         1824 my @fstabs = `$grep -v cdr $fstab`;
798              
799             # foreach my $fstab (@fstabs)
800             # {}
801             # my @fields = split(/ /, $fstab);
802             # #print "device: $fields[0] mount: $fields[1]\n";
803             # {};
804             # print "\n\n END of fstabs\n\n";
805              
806 1         20 return \@fstabs;
807             }
808              
809             sub get_cpan_config {
810              
811 0     0 0 0 my $ftp = `which ftp`; chomp $ftp;
  0         0  
812 0         0 my $gzip = `which gzip`; chomp $gzip;
  0         0  
813 0         0 my $unzip = `which unzip`; chomp $unzip;
  0         0  
814 0         0 my $tar = `which tar`; chomp $tar;
  0         0  
815 0         0 my $make = `which make`; chomp $make;
  0         0  
816 0         0 my $wget = `which wget`; chomp $wget;
  0         0  
817              
818             return
819             {
820 0         0 'build_cache' => q[10],
821             'build_dir' => qq[$ENV{HOME}/.cpan/build],
822             'cache_metadata' => q[1],
823             'cpan_home' => qq[$ENV{HOME}/.cpan],
824             'ftp' => $ftp,
825             'ftp_proxy' => q[],
826             'getcwd' => q[cwd],
827             'gpg' => q[],
828             'gzip' => $gzip,
829             'histfile' => qq[$ENV{HOME}/.cpan/histfile],
830             'histsize' => q[100],
831             'http_proxy' => q[],
832             'inactivity_timeout' => q[5],
833             'index_expire' => q[1],
834             'inhibit_startup_message' => q[1],
835             'keep_source_where' => qq[$ENV{HOME}/.cpan/sources],
836             'lynx' => q[],
837             'make' => $make,
838             'make_arg' => q[],
839             'make_install_arg' => q[],
840             'makepl_arg' => q[],
841             'ncftp' => q[],
842             'ncftpget' => q[],
843             'no_proxy' => q[],
844             'pager' => q[less],
845             'prerequisites_policy' => q[follow],
846             'scan_cache' => q[atstart],
847             'shell' => q[/bin/csh],
848             'tar' => $tar,
849             'term_is_latin' => q[1],
850             'unzip' => $unzip,
851             '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/' ],
852             'wget' => $wget,
853             };
854              
855             }
856              
857             sub get_dir_files {
858 3     3 1 547 my $self = shift;
859 3 50       16 my $dir = shift or die "missing dir name";
860 3         34 my %p = validate( @_, { $self->get_std_opts } );
861              
862 3         29 my %args = $self->get_std_args( %p );
863              
864 3         8 my @files;
865              
866 3 50       70 return $self->error( "dir $dir is not a directory!", %args)
867             if ! -d $dir;
868              
869 3 50       93 opendir D, $dir or return $self->error( "couldn't open $dir: $!", %args );
870              
871 3         330 while ( defined( my $f = readdir(D) ) ) {
872 143 100       213 next if $f =~ /^\.\.?$/;
873 137         298 push @files, "$dir/$f";
874             }
875              
876 3         47 closedir(D);
877              
878 3         42 return @files;
879             }
880              
881             sub get_my_ips {
882              
883             ############################################
884             # Usage : @list_of_ips_ref = $util->get_my_ips();
885             # Purpose : get a list of IP addresses on local interfaces
886             # Returns : an arrayref of IP addresses
887             # Parameters : only - can be one of: first, last
888             # : exclude_locahost (all 127.0 addresses)
889             # : exclude_internals (192.168, 10., 169., 172.)
890             # : exclude_ipv6
891             # Comments : exclude options are boolean and enabled by default.
892             # tested on Mac OS X and FreeBSD
893              
894 0     0 1 0 my $self = shift;
895 0         0 my %p = validate(
896             @_,
897             { 'only' => { type => SCALAR, optional => 1, default => 0 },
898             'exclude_localhost' =>
899             { type => BOOLEAN, optional => 1, default => 1 },
900             'exclude_internals' =>
901             { type => BOOLEAN, optional => 1, default => 1 },
902             'exclude_ipv6' =>
903             { type => BOOLEAN, optional => 1, default => 1 },
904             $self->get_std_opts,
905             }
906             );
907              
908 0         0 my $only = $p{only};
909              
910 0         0 my $ifconfig = $self->find_bin( "ifconfig", verbose => 0 );
911              
912 0         0 my $once = 0;
913              
914             TRY:
915 0         0 my @ips = grep {/inet/} `$ifconfig`; chomp @ips;
  0         0  
  0         0  
916 0 0       0 @ips = grep {!/inet6/} @ips if $p{exclude_ipv6};
  0         0  
917 0 0       0 @ips = grep {!/inet 127\.0\.0/} @ips if $p{exclude_localhost};
  0         0  
918 0         0 @ips = grep {!/inet (192\.168\.|10\.|172\.16\.|169\.254\.)/} @ips
919 0 0       0 if $p{exclude_internals};
920              
921             # this keeps us from failing if the box has only internal IPs
922 0 0 0     0 if ( @ips < 1 || $ips[0] eq "" ) {
923 0         0 $self->audit( "yikes, you really don't have any public IPs?!");
924 0         0 $p{exclude_internals} = 0;
925 0         0 $once++;
926 0 0       0 goto TRY if ( $once < 2 );
927             }
928              
929 0         0 foreach ( @ips ) { ($_) = $_ =~ m/inet ([\d\.]+)\s/; };
  0         0  
930              
931 0 0       0 return [ $ips[0] ] if $only eq 'first';
932 0 0       0 return [ $ips[-1] ] if $only eq 'last';
933 0         0 return \@ips;
934             }
935              
936             sub get_the_date {
937 5     5 1 28914 my $self = shift;
938 5         37 my %p = validate(
939             @_,
940             { 'bump' => { type => SCALAR, optional => 1, },
941             $self->get_std_opts
942             }
943             );
944              
945 5   100     50 my $bump = $p{bump} || 0;
946 5         28 my %args = $self->get_std_args( %p );
947              
948 5         18 my $time = time;
949 5         16 my $mess = "get_the_date time: " . time;
950              
951 5 100       15 $bump = $bump * 86400 if $bump;
952 5         7 my $offset_time = time - $bump;
953 5 100       21 $mess .= ", (selected $offset_time)" if $time != $offset_time;
954              
955             # load Date::Format to get the time2str function
956 5         8 eval { require Date::Format };
  5         35  
957 5 50       15 if ( !$EVAL_ERROR ) {
958              
959 5         18 my $ss = Date::Format::time2str( "%S", ($offset_time) );
960 5         373 my $mn = Date::Format::time2str( "%M", ($offset_time) );
961 5         222 my $hh = Date::Format::time2str( "%H", ($offset_time) );
962 5         214 my $dd = Date::Format::time2str( "%d", ($offset_time) );
963 5         172 my $mm = Date::Format::time2str( "%m", ($offset_time) );
964 5         159 my $yy = Date::Format::time2str( "%Y", ($offset_time) );
965 5         165 my $lm = Date::Format::time2str( "%m", ( $offset_time - 2592000 ) );
966              
967 5         193 $self->audit( "$mess, $yy/$mm/$dd $hh:$mn", %args);
968 5         54 return $dd, $mm, $yy, $lm, $hh, $mn, $ss;
969             }
970              
971             # 0 1 2 3 4 5 6 7 8
972             # ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
973             # localtime(time);
974             # 4 = month + 1 ( see perldoc localtime)
975             # 5 = year + 1900 ""
976              
977 0         0 my @fields = localtime($offset_time);
978              
979 0         0 my $ss = sprintf( "%02i", $fields[0] ); # seconds
980 0         0 my $mn = sprintf( "%02i", $fields[1] ); # minutes
981 0         0 my $hh = sprintf( "%02i", $fields[2] ); # hours (24 hour clock)
982              
983 0         0 my $dd = sprintf( "%02i", $fields[3] ); # day of month
984 0         0 my $mm = sprintf( "%02i", $fields[4] + 1 ); # month
985 0         0 my $yy = ( $fields[5] + 1900 ); # year
986              
987 0         0 $self->audit( "$mess, $yy/$mm/$dd $hh:$mn", %args );
988 0         0 return $dd, $mm, $yy, undef, $hh, $mn, $ss;
989             }
990              
991             sub get_mounted_drives {
992 1     1 1 3 my $self = shift;
993 1         4 my %p = validate( @_, { $self->get_std_opts } );
994 1         6 my %args = $self->get_std_args( %p );
995              
996 1         7 my $mount = $self->find_bin( 'mount', %args );
997              
998 1 50       34 -x $mount or return $self->error( "I couldn't find mount!", %args );
999              
1000 1         9 $ENV{PATH} = "";
1001 1         3 my %hash;
1002 1         22900 foreach (`$mount`) {
1003 31         170 my ( $d, $m ) = $_ =~ /^(.*) on (.*) \(/;
1004              
1005             #if ( $m =~ /^\// && $d =~ /^\// ) # mount drives that begin with /
1006 31 50 33     137 if ( $m && $m =~ /^\// ) { # only mounts that begin with /
1007 31         116 $self->audit( "adding: $m \t $d" );
1008 31         101 $hash{$m} = $d;
1009             }
1010             }
1011 1         23 return \%hash;
1012             }
1013              
1014             sub get_url {
1015 0     0 1 0 my $self = shift;
1016 0         0 my $url = shift;
1017 0         0 my %p = validate(
1018             @_,
1019             { dir => { type => SCALAR, optional => 1 },
1020             timeout => { type => SCALAR, optional => 1 },
1021             $self->get_std_opts,
1022             }
1023             );
1024              
1025 0         0 my $dir = $p{dir};
1026 0         0 my %args = $self->get_std_args( %p );
1027              
1028 0         0 my ($ua, $response);
1029 0         0 eval "require LWP::Simple"; ## no critic ( StringyEval )
1030 0 0       0 if ( $EVAL_ERROR ) {
1031 0         0 $self->audit( "LWP::Simple not installed" );
1032 0         0 return $self->get_url_system( $url, %p );
1033             };
1034              
1035 0         0 eval "require URI"; ## no critic ( StringyEval )
1036 0 0       0 return $self->error( $@, fatal => $p{fatal} ) if $@;
1037 0         0 my $uri = URI->new($url);
1038 0         0 my @parts = $uri->path_segments;
1039 0         0 my $file = $parts[-1]; # everything after the last / in the URL
1040 0         0 my $file_path = $file;
1041 0 0       0 $file_path = "$dir/$file" if $dir;
1042              
1043 0         0 $self->audit( "fetching $url" );
1044 0         0 eval { $response = LWP::Simple::mirror($url, $file_path ); };
  0         0  
1045 0 0       0 $self->error( $EVAL_ERROR ) if $EVAL_ERROR;
1046              
1047 0 0       0 if ( $response ) {
1048 0 0       0 if ( $response == 404 ) {
    0          
    0          
1049 0         0 return $self->error( "file not found ($url)", %args );
1050             }
1051             elsif ($response == 304 ) {
1052 0         0 $self->audit( "result 304: file is up-to-date" );
1053             }
1054             elsif ( $response == 200 ) {
1055 0         0 $self->audit( "result 200: file download ok" );
1056             }
1057             else {
1058 0         0 $self->error( "unhandled response: $response for $url", fatal => 0 );
1059             };
1060             };
1061              
1062 0 0       0 $self->error( "download failed for $url!") if ! -e $file_path;
1063 0         0 return $response;
1064             }
1065              
1066             sub get_url_system {
1067 0     0 0 0 my $self = shift;
1068 0         0 my $url = shift;
1069 0         0 my %p = validate(
1070             @_,
1071             { dir => { type => SCALAR, optional => 1 },
1072             timeout => { type => SCALAR, optional => 1, },
1073             $self->get_std_opts,
1074             }
1075             );
1076              
1077 0         0 my $dir = $p{dir};
1078 0         0 my $verbose = $p{verbose};
1079 0         0 my %args = $self->get_std_args( %p );
1080              
1081 0         0 my ($fetchbin, $found);
1082 0 0       0 if ( $OSNAME eq "freebsd" ) {
    0          
1083 0         0 $fetchbin = $self->find_bin( 'fetch', %args);
1084 0 0 0     0 if ( $fetchbin && -x $fetchbin ) {
1085 0         0 $found = $fetchbin;
1086 0 0       0 $found .= " -q" if !$verbose;
1087             }
1088             }
1089             elsif ( $OSNAME eq "darwin" ) {
1090 0         0 $fetchbin = $self->find_bin( 'curl', %args );
1091 0 0 0     0 if ( $fetchbin && -x $fetchbin ) {
1092 0         0 $found = "$fetchbin -O";
1093 0 0       0 $found .= " -s " if !$verbose;
1094             }
1095             }
1096              
1097 0 0       0 if ( !$found ) {
1098 0         0 $fetchbin = $self->find_bin( 'wget', %args);
1099 0 0 0     0 $found = $fetchbin if $fetchbin && -x $fetchbin;
1100             }
1101              
1102 0 0       0 return $self->error( "Failed to fetch $url.\n\tCouldn't find wget. Please install it.", %args )
1103             if !$found;
1104              
1105 0         0 my $fetchcmd = "$found $url";
1106              
1107 0   0     0 my $timeout = $p{timeout} || 0;
1108 0 0       0 if ( ! $timeout ) {
1109 0 0       0 $self->syscmd( $fetchcmd, %args ) or return;
1110 0         0 eval "require URI"; ## no critic ( StringyEval )
1111 0 0       0 return $self->error( $@, fatal => $p{fatal} ) if $@;
1112 0         0 my $uri = URI->new($url);
1113 0         0 my @parts = $uri->path_segments;
1114 0         0 my $file = $parts[-1]; # everything after the last / in the URL
1115 0 0 0     0 if ( -e $file && $dir && -d $dir ) {
      0        
1116 0         0 $self->audit("moving file $file to $dir" );
1117 0         0 move $file, "$dir/$file";
1118 0         0 return 1;
1119             };
1120             };
1121              
1122 0         0 my $r;
1123 0         0 eval {
1124 0     0   0 local $SIG{ALRM} = sub { die "alarm\n" };
  0         0  
1125 0         0 alarm $timeout;
1126 0         0 $r = $self->syscmd( $fetchcmd, %args );
1127 0         0 alarm 0;
1128             };
1129              
1130 0 0       0 if ($EVAL_ERROR) { # propagate unexpected errors
1131 0 0       0 print "timed out!\n" if $EVAL_ERROR eq "alarm\n";
1132 0         0 return $self->error( $EVAL_ERROR, %args );
1133             }
1134              
1135 0 0       0 return $self->error( "error executing $fetchcmd", %args) if !$r;
1136 0         0 return 1;
1137             }
1138              
1139             sub has_module {
1140 16     16 0 25 my $self = shift;
1141 16         27 my ($name, $ver) = @_;
1142              
1143             ## no critic ( ProhibitStringyEval )
1144 16 50   2   1317 eval "use $name" . ($ver ? " $ver;" : ";");
  2     2   1061  
  2     2   150294  
  2     2   208  
  2     2   14  
  2     2   4  
  2     2   130  
  2     2   15  
  2         2  
  2         133  
  2         16  
  2         2  
  2         164  
  2         13  
  2         2  
  2         117  
  2         15  
  2         2  
  2         143  
  2         15  
  2         3  
  2         134  
  2         16  
  2         3  
  2         150  
1145             ## use critic
1146              
1147 16         89 !$EVAL_ERROR;
1148             };
1149              
1150             sub install_if_changed {
1151 1     1 0 11 my $self = shift;
1152 1         49 my %p = validate(
1153             @_,
1154             { newfile => { type => SCALAR, optional => 0, },
1155             existing=> { type => SCALAR, optional => 0, },
1156             mode => { type => SCALAR, optional => 1, },
1157             uid => { type => SCALAR, optional => 1, },
1158             gid => { type => SCALAR, optional => 1, },
1159             sudo => { type => BOOLEAN, optional => 1, default => 0 },
1160             notify => { type => BOOLEAN, optional => 1, },
1161             email => { type => SCALAR, optional => 1, default => 'postmaster' },
1162             clean => { type => BOOLEAN, optional => 1, default => 1 },
1163             archive => { type => BOOLEAN, optional => 1, default => 0 },
1164             $self->get_std_opts,
1165             },
1166             );
1167              
1168             my ( $newfile, $existing, $mode, $uid, $gid, $email) = (
1169 1         12 $p{newfile}, $p{existing}, $p{mode}, $p{uid}, $p{gid}, $p{email} );
1170 1         4 my ($sudo, $notify ) = ($p{sudo}, $p{notify} );
1171 1         8 my %args = $self->get_std_args( %p );
1172              
1173 1 50       10 if ( $newfile !~ /\// ) {
1174             # relative filename given
1175 0         0 $self->audit( "relative filename given, use complete paths "
1176             . "for more predicatable results!\n"
1177             . "working directory is " . cwd() );
1178             }
1179              
1180 1 50       21 return $self->error( "file ($newfile) does not exist", %args )
1181             if !-e $newfile;
1182              
1183 1 50       13 return $self->error( "file ($newfile) is not a file", %args )
1184             if !-f $newfile;
1185              
1186             # make sure existing and new are writable
1187 1 50 33     6 if ( !$self->is_writable( $existing, fatal => 0 )
1188             || !$self->is_writable( $newfile, fatal => 0 ) ) {
1189              
1190             # root does not have permission, sudo won't do any good
1191 0 0       0 return $self->error("no write permission", %args) if $UID == 0;
1192              
1193 0 0       0 if ( $sudo ) {
1194 0 0       0 $sudo = $self->find_bin( 'sudo', %args ) or
1195             return $self->error( "you are not root, sudo was not found, and you don't have permission to write to $newfile or $existing" );
1196             }
1197             }
1198              
1199 1         2 my $diffie;
1200 1 50       13 if ( -f $existing ) {
1201             $diffie = $self->files_diff( %args,
1202             f1 => $newfile,
1203             f2 => $existing,
1204             type => "text",
1205 1 50       9 ) or do {
1206 1         17 $self->audit( "$existing is already up-to-date.", %args);
1207 1 50       5 unlink $newfile if $p{clean};
1208 1         23 return 2;
1209             };
1210             };
1211              
1212 0         0 $self->audit("checking $existing", %args);
1213              
1214 0 0 0     0 $self->chown( $newfile,
1215             uid => $uid,
1216             gid => $gid,
1217             sudo => $sudo,
1218             %args
1219             )
1220             if ( $uid && $gid ); # set file ownership on the new file
1221              
1222             # set file permissions on the new file
1223 0 0 0     0 $self->chmod(
1224             file_or_dir => $existing,
1225             mode => $mode,
1226             sudo => $sudo,
1227             %args
1228             )
1229             if ( -e $existing && $mode );
1230              
1231 0         0 $self->install_if_changed_notify( $notify, $email, $existing, $diffie);
1232 0 0 0     0 $self->archive_file( $existing, %args) if ( -e $existing && $p{archive} );
1233 0         0 $self->install_if_changed_copy( $sudo, $newfile, $existing, $p{clean}, \%args );
1234              
1235 0 0 0     0 $self->chown( $existing,
1236             uid => $uid,
1237             gid => $gid,
1238             sudo => $sudo,
1239             %args
1240             ) if ( $uid && $gid ); # set ownership on new existing file
1241              
1242 0 0       0 $self->chmod(
1243             file_or_dir => $existing,
1244             mode => $mode,
1245             sudo => $sudo,
1246             %args
1247             )
1248             if $mode; # set file permissions (paranoid)
1249              
1250 0         0 $self->audit( " updated $existing" );
1251 0         0 return 1;
1252             }
1253              
1254             sub install_if_changed_copy {
1255 0     0 0 0 my $self = shift;
1256 0         0 my ( $sudo, $newfile, $existing, $clean, $args ) = @_;
1257              
1258             # install the new file
1259 0 0       0 if ($sudo) {
1260 0         0 my $cp = $self->find_bin( 'cp', %$args );
1261              
1262             # back up the existing file
1263 0 0       0 $self->syscmd( "$sudo $cp $existing $existing.bak", %$args)
1264             if -e $existing;
1265              
1266             # install the new one
1267 0 0       0 if ( $clean ) {
1268 0         0 my $mv = $self->find_bin( 'mv' );
1269 0         0 $self->syscmd( "$sudo $mv $newfile $existing", %$args);
1270             }
1271             else {
1272 0         0 $self->syscmd( "$sudo $cp $newfile $existing",%$args);
1273             }
1274             }
1275             else {
1276              
1277             # back up the existing file
1278 0 0       0 copy( $existing, "$existing.bak" ) if -e $existing;
1279              
1280 0 0       0 if ( $clean ) {
1281 0 0       0 move( $newfile, $existing ) or
1282             return $self->error( "failed move $newfile to $existing", %$args);
1283             }
1284             else {
1285 0 0       0 copy( $newfile, $existing ) or
1286             return $self->error( "failed copy $newfile to $existing", %$args );
1287             }
1288             }
1289             };
1290              
1291             sub install_if_changed_notify {
1292              
1293 0     0 0 0 my ($self, $notify, $email, $existing, $diffie) = @_;
1294              
1295 0 0       0 return if ! $notify;
1296 0 0       0 return if ! -f $existing;
1297              
1298             # email diffs to admin
1299              
1300 0         0 eval { require Mail::Send; };
  0         0  
1301              
1302 0 0       0 return $self->error( "could not send notice, Mail::Send is not installed!", fatal => 0)
1303             if $EVAL_ERROR;
1304              
1305 0         0 my $msg = Mail::Send->new;
1306 0         0 $msg->subject("$existing updated by $0");
1307 0         0 $msg->to($email);
1308 0         0 my $email_message = $msg->open;
1309              
1310 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";
1311              
1312 0         0 $email_message->close;
1313             };
1314              
1315             sub install_from_source {
1316 2     2 1 5 my $self = shift;
1317 2         25 my %p = validate(
1318             @_,
1319             { 'site' => { type => SCALAR, optional => 0, },
1320             'url' => { type => SCALAR, optional => 0, },
1321             'package' => { type => SCALAR, optional => 0, },
1322             'targets' => { type => ARRAYREF, optional => 1, },
1323             'patches' => { type => ARRAYREF, optional => 1, },
1324             'patch_url' => { type => SCALAR, optional => 1, },
1325             'patch_args' => { type => SCALAR, optional => 1, },
1326             'source_dir' => { type => SCALAR, optional => 1, },
1327             'source_sub_dir' => { type => SCALAR, optional => 1, },
1328             'bintest' => { type => SCALAR, optional => 1, },
1329             $self->get_std_opts,
1330             },
1331             );
1332              
1333 2 50       32 return $p{test_ok} if defined $p{test_ok};
1334 0         0 my %args = $self->get_std_args( %p );
1335              
1336             my ( $site, $url, $package, $targets, $patches, $bintest ) =
1337             ( $p{site}, $p{url}, $p{package},
1338 0         0 $p{targets}, $p{patches}, $p{bintest} );
1339              
1340 0   0     0 my $patch_args = $p{patch_args} || '';
1341 0   0     0 my $srcdir = $p{source_dir} || "/usr/local/src";
1342 0 0       0 $srcdir .= "/$p{source_sub_dir}" if $p{source_sub_dir};
1343              
1344 0 0 0     0 if ( $bintest && $self->find_bin( $bintest, fatal => 0, verbose => 0 ) ) {
1345 0 0       0 return if ! $self->yes_or_no(
1346             "$bintest exists, suggesting that "
1347             . "$package is installed. Do you want to reinstall?",
1348             timeout => 60,
1349             );
1350             }
1351              
1352 0         0 $self->audit( "install_from_source: building $package in $srcdir" );
1353              
1354 0         0 my $original_directory = cwd;
1355 0         0 $self->cwd_source_dir( $srcdir, %args );
1356              
1357 0 0       0 $self->install_from_source_cleanup($package,$srcdir) or return;
1358 0 0       0 $self->install_from_source_get_files($package,$site,$url,$p{patch_url},$patches) or return;
1359 0 0       0 $self->extract_archive( $package ) or return;
1360              
1361             # cd into the package directory
1362 0         0 my $sub_path;
1363 0 0       0 if ( -d $package ) {
1364 0 0       0 chdir $package or
1365             return $self->error( "FAILED to chdir $package!", %args );
1366             }
1367             else {
1368              
1369             # some packages (like daemontools) unpack within an enclosing directory
1370 0         0 $sub_path = `find ./ -name $package`; # tainted data
1371 0         0 chomp $sub_path;
1372 0         0 ($sub_path) = $sub_path =~ /^([-\w\/.]+)$/; # untaint it
1373              
1374 0 0       0 $self->audit( "found sources in $sub_path" ) if $sub_path;
1375 0 0 0     0 return $self->error( "FAILED to find $package sources!",fatal=>0)
1376             unless ( -d $sub_path && chdir $sub_path );
1377             }
1378              
1379 0 0       0 $self->install_from_source_apply_patches($srcdir, $patches, $patch_args) or return;
1380              
1381             # set default build targets if none are provided
1382 0 0       0 if ( !@$targets[0] ) {
1383 0         0 $self->audit( "\tusing default targets (./configure, make, make install)" );
1384 0         0 @$targets = ( "./configure", "make", "make install" );
1385             }
1386              
1387 0         0 my $msg = "install_from_source: using targets\n";
1388 0         0 foreach (@$targets) { $msg .= "\t$_\n" };
  0         0  
1389 0         0 $self->audit( $msg );
1390              
1391             # build the program
1392 0         0 foreach my $target (@$targets) {
1393              
1394 0 0       0 if ( $target =~ /^cd (.*)$/ ) {
1395 0         0 $self->audit( "cwd: " . cwd . " -> " . $1 );
1396 0 0       0 chdir($1) or return $self->error( "couldn't chdir $1: $!", %args);
1397 0         0 next;
1398             }
1399              
1400 0 0       0 $self->syscmd( $target, %args ) or
1401             return $self->error( "pwd: " . cwd . "\n$target failed: $!", %args );
1402             }
1403              
1404             # clean up the build sources
1405 0         0 chdir $srcdir;
1406 0 0       0 File::Path::rmtree($package) if -d $package;
1407              
1408 0 0 0     0 if ( defined $sub_path && -d "$package/$sub_path" ) {
1409 0         0 File::Path::rmtree( "$package/$sub_path" );
1410             };
1411              
1412 0         0 chdir $original_directory;
1413 0         0 return 1;
1414             }
1415              
1416             sub install_from_source_apply_patches {
1417 0     0 0 0 my $self = shift;
1418 0         0 my ($src, $patches,$patch_args) = @_;
1419              
1420 0 0       0 return 1 if ! $patches;
1421 0 0       0 return 1 if ! $patches->[0];
1422              
1423 0         0 my $patchbin = $self->find_bin( "patch" );
1424 0         0 foreach my $patch (@$patches) {
1425 0 0       0 $self->syscmd( "$patchbin $patch_args < $src/$patch" )
1426             or return $self->error("failed to apply patch $patch");
1427             }
1428 0         0 return 1;
1429             };
1430              
1431             sub install_from_source_cleanup {
1432 0     0 0 0 my $self = shift;
1433 0         0 my ($package,$src) = @_;
1434              
1435             # make sure there are no previous sources in the way
1436 0 0       0 return 1 if ! -d $package;
1437              
1438 0 0       0 $self->source_warning(
1439             package => $package,
1440             clean => 1,
1441             src => $src,
1442             ) or return $self->error( "OK then, skipping install.", fatal => 0);
1443              
1444 0         0 $self->audit( " removing previous build sources." );
1445 0         0 foreach my $dir ( glob "$package-*" ) {
1446 0 0       0 File::Path::rmtree( $dir )
1447             or return $self->error("failed to delete $package: $!");
1448             };
1449 0         0 return 1;
1450             };
1451              
1452             sub install_from_source_get_files {
1453 0     0 0 0 my $self = shift;
1454 0         0 my ($package,$site,$url,$patch_url,$patches) = @_;
1455              
1456 0 0       0 $self->sources_get(
1457             package => $package,
1458             site => $site,
1459             path => $url,
1460             ) or return;
1461              
1462 0 0 0     0 if ( ! $patches || ! $patches->[0] ) {
1463 0         0 $self->audit( " no patches" );
1464 0         0 return 1;
1465             };
1466              
1467 0 0       0 return $self->error( "oops! You supplied patch names to apply without a URL!")
1468             if ! $patch_url;
1469              
1470 0         0 foreach my $patch (@$patches) {
1471 0 0       0 next if ! $patch;
1472 0 0       0 next if -e $patch;
1473 0         0 $self->get_url( "$patch_url/$patch" );
1474             };
1475              
1476 0         0 return 1;
1477             };
1478              
1479             sub install_package {
1480 0     0 0 0 my ($self, $app, $info) = @_;
1481              
1482 0 0       0 if ( lc($OSNAME) eq 'freebsd' ) {
1483              
1484             my $portname = $info->{port}
1485 0 0       0 or return $self->error( "skipping install of $app b/c port dir not set.", fatal => 0);
1486              
1487 0         0 require Mail::Toaster::FreeBSD;
1488 0         0 my $freebsd = Mail::Toaster::FreeBSD->new;
1489 0 0       0 if ( $freebsd->is_port_installed( $app ) ) {
1490 0         0 print "$app is installed.\n";
1491 0         0 return 1;
1492             }
1493              
1494 0         0 print "installing $app\n";
1495 0         0 my $portdir = glob("/usr/ports/*/$portname");
1496              
1497 0 0 0     0 return $self->error( "oops, couldn't find port $app at '$portname'")
1498             if ( ! -d $portdir || ! chdir $portdir );
1499              
1500 0 0       0 system "make install clean"
1501             and return $self->error( "'make install clean' failed for port $app", fatal => 0);
1502 0         0 return 1;
1503             };
1504              
1505 0 0       0 if ( lc($OSNAME) eq 'linux' ) {
1506 0 0       0 my $rpm = $info->{rpm} or return $self->error("skipping install of $app b/c rpm not set", fatal => 0);
1507 0         0 my $yum = '/usr/bin/yum';
1508 0 0       0 return $self->error( "couldn't find yum, skipping install.", fatal => 0)
1509             if ! -x $yum;
1510 0         0 return system "$yum install $rpm";
1511             };
1512              
1513 0         0 $self->error(" no package support for $OSNAME ");
1514             }
1515              
1516             sub install_module {
1517 0     0 0 0 my ($self, $module, %info) = @_;
1518              
1519 0 0       0 if ( lc($OSNAME) eq 'darwin' ) {
    0          
    0          
1520 0 0       0 $self->install_module_darwin( $module ) and return 1;
1521             }
1522             elsif ( lc($OSNAME) eq 'freebsd' ) {
1523 0 0       0 $self->install_module_freebsd( $module, \%info) and return 1;
1524             }
1525             elsif ( lc($OSNAME) eq 'linux' ) {
1526 0 0       0 $self->install_module_linux( $module, \%info) and return 1;
1527             };
1528              
1529 0         0 $self->install_module_cpan( $module );
1530              
1531 0         0 eval "use $module"; ## no critic ( StringyEval )
1532 0 0       0 if ( ! $EVAL_ERROR ) {
1533 0         0 $self->audit( "$module is installed." );
1534 0         0 return 1;
1535             };
1536 0         0 return;
1537             }
1538              
1539             sub install_module_cpan {
1540 0     0 0 0 my $self = shift;
1541 0         0 my ($module, $version) = @_;
1542              
1543 0         0 print " from CPAN...";
1544 0         0 require CPAN;
1545              
1546             # some Linux distros break CPAN by auto/preconfiguring it with no URL mirrors.
1547             # this works around that annoying little habit
1548 11     11   67 no warnings;
  11         14  
  11         487  
1549 0         0 $CPAN::Config = get_cpan_config();
1550 11     11   34 use warnings;
  11         15  
  11         37509  
1551              
1552 0 0 0     0 if ( $module eq 'Provision::Unix' && $version ) {
1553 0         0 $module =~ s/\:\:/\-/g;
1554 0         0 $module = "M/MS/MSIMERSON/$module-$version.tar.gz";
1555             }
1556 0         0 CPAN::Shell->install($module);
1557             }
1558              
1559             sub install_module_darwin {
1560 0     0 0 0 my $self = shift;
1561 0         0 my $module = shift;
1562              
1563 0         0 my $dport = '/opt/local/bin/port';
1564 0 0       0 return $self->error( "Darwin ports is not installed!", fatal => 0)
1565             if ! -x $dport;
1566              
1567 0         0 my $port = lc "p5-$module";
1568 0         0 $port =~ s/::/-/g;
1569 0 0       0 system "sudo $dport install $port" or return 1;
1570 0         0 return;
1571             };
1572              
1573             sub install_module_freebsd {
1574 0     0 0 0 my $self = shift;
1575 0         0 my ($module, $info) = @_;
1576              
1577 0         0 my $portname = $info->{port}; # optional override
1578 0 0       0 if ( ! $portname ) {
1579 0         0 $portname = "p5-$module";
1580 0         0 $portname =~ s/::/-/g;
1581             };
1582              
1583 0 0       0 return 1 if $self->freebsd->is_port_installed( $portname );
1584 0 0       0 return 1 if $self->freebsd->install_package( $portname );
1585              
1586 0         0 my $portdir = glob("/usr/ports/*/$portname");
1587 0 0       0 return if ! $portdir;
1588 0 0       0 return if ! -d $portdir;
1589              
1590 0         0 $self->audit( "installing $module from ports ($portdir)" );
1591 0         0 system "make -C $portdir clean install clean";
1592 0         0 return 1;
1593             }
1594              
1595             sub install_module_from_src {
1596 0     0 0 0 my $self = shift;
1597 0         0 my %p = validate( @_, {
1598             module => { type=>SCALAR, optional=>0, },
1599             archive => { type=>SCALAR, optional=>0, },
1600             site => { type=>SCALAR, optional=>0, },
1601             url => { type=>SCALAR, optional=>0, },
1602             src => { type=>SCALAR, optional=>1, default=>'/usr/local/src' },
1603             targets => { type=>ARRAYREF,optional=>1, },
1604             $self->get_std_opts,
1605             },
1606             );
1607              
1608             my ( $module, $site, $url, $src, $targets )
1609 0         0 = ( $p{module}, $p{site}, $p{url}, $p{src}, $p{targets} );
1610 0         0 my %args = $self->get_std_args( %p );
1611              
1612 0         0 $self->cwd_source_dir( $src, %args );
1613              
1614 0         0 $self->audit( "checking for previous build attempts.");
1615 0 0       0 if ( -d $module ) {
1616 0 0       0 if ( ! $self->source_warning( package=>$module, src=>$src, %args ) ) {
1617 0         0 print "\nokay, skipping install.\n";
1618 0         0 return;
1619             }
1620 0 0       0 File::Path::rmtree( "$module" ) or die $!;
1621             }
1622              
1623             $self->sources_get(
1624             site => $site,
1625             path => $url,
1626 0 0 0     0 package => $p{'archive'} || $module,
1627             %args,
1628             ) or return;
1629              
1630 0 0       0 $self->extract_archive( $module ) or return;
1631              
1632 0         0 my $found;
1633 0         0 print "looking for $module in $src...";
1634 0         0 foreach my $file ( $self->get_dir_files( $src ) ) {
1635              
1636 0 0       0 next if ! -d $file; # only check directories
1637 0 0       0 next if $file !~ /$module/;
1638              
1639 0         0 print "found: $file\n";
1640 0         0 $found++;
1641 0         0 chdir $file;
1642              
1643 0 0 0     0 unless ( @$targets[0] && @$targets[0] ne "" ) {
1644 0         0 $self->audit( "using default targets." );
1645 0         0 $targets = [ "perl Makefile.PL", "make", "make install" ];
1646             }
1647              
1648 0         0 print "building with targets " . join( ", ", @$targets ) . "\n";
1649 0         0 foreach (@$targets) {
1650 0 0       0 return $self->error( "$_ failed!", %args)
1651             if ! $self->syscmd( cmd => $_ , %args);
1652             }
1653              
1654 0         0 chdir('..');
1655 0 0       0 File::Path::rmtree( $file ) or die $!;
1656 0         0 last;
1657             }
1658              
1659 0         0 return $found;
1660             }
1661              
1662             sub install_module_linux {
1663 0     0 0 0 my $self = shift;
1664 0         0 my ($module, $info ) = @_;
1665 0         0 my $rpm = $info->{rpm};
1666 0 0       0 if ( $rpm ) {
1667 0         0 my $portname = "perl-$rpm";
1668 0         0 $portname =~ s/::/-/g;
1669 0         0 my $yum = '/usr/bin/yum';
1670 0 0       0 system "$yum -y install $portname" if -x $yum;
1671             }
1672             };
1673              
1674             sub is_interactive {
1675              
1676             ## no critic
1677             # borrowed from IO::Interactive
1678 0     0 1 0 my $self = shift;
1679 0         0 my ($out_handle) = ( @_, select ); # Default to default output handle
1680              
1681             # Not interactive if output is not to terminal...
1682 0 0       0 return if not -t $out_handle;
1683              
1684             # If *ARGV is opened, we're interactive if...
1685 0 0       0 if ( openhandle * ARGV ) {
1686              
1687             # ...it's currently opened to the magic '-' file
1688 0 0 0     0 return -t *STDIN if defined $ARGV && $ARGV eq '-';
1689              
1690             # ...it's at end-of-file and the next file is the magic '-' file
1691 0 0 0     0 return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;
1692              
1693             # ...it's directly attached to the terminal
1694 0         0 return -t *ARGV;
1695             };
1696              
1697             # If *ARGV isn't opened, it will be interactive if *STDIN is attached
1698             # to a terminal and either there are no files specified on the command line
1699             # or if there are files and the first is the magic '-' file
1700 0   0     0 return -t *STDIN && ( @ARGV == 0 || $ARGV[0] eq '-' );
1701             }
1702              
1703             sub is_process_running {
1704 13     13 1 43 my ( $self, $process ) = @_;
1705              
1706 13         88 my $ps = $self->find_bin( 'ps', verbose => 0 );
1707              
1708 13 50       245 if ( lc($OSNAME) =~ /solaris/i ) { $ps .= ' -ef'; }
  0 50       0  
    50          
1709 0         0 elsif ( lc($OSNAME) =~ /irix/i ) { $ps .= ' -ef'; }
1710 13         27 elsif ( lc($OSNAME) =~ /linux/i ) { $ps .= ' -efw'; }
1711 0         0 else { $ps .= ' axww'; };
1712              
1713 13         69102 my @procs = `$ps`;
1714 13         70 chomp @procs;
1715 13         88 return scalar grep {/$process/i} @procs;
  156         868  
1716             }
1717              
1718             sub is_readable {
1719 2     2 1 5 my $self = shift;
1720 2 50       9 my $file = shift or die "missing file or dir name\n";
1721 2         8 my %p = validate( @_, { $self->get_std_opts } );
1722              
1723 2         9 my %args = ( verbose => $p{verbose}, fatal => $p{fatal} );
1724              
1725 2 100       37 -e $file or return $self->error( "$file does not exist.", %args);
1726 1 50       10 -r $file or return $self->error( "$file is not readable by you ("
1727             . getpwuid($>)
1728             . "). You need to fix this, using chown or chmod.", %args);
1729              
1730 1         7 return 1;
1731             }
1732              
1733             sub is_writable {
1734 23     23 1 38 my $self = shift;
1735 23 50       60 my $file = shift or die "missing file or dir name\n";
1736              
1737 23         51 my %p = validate( @_, { $self->get_std_opts } );
1738 23         101 my %args = $self->get_std_args( %p );
1739              
1740 23         36 my $nl = "\n";
1741 23 50       46 $nl = "<br>" if ( $ENV{GATEWAY_INTERFACE} );
1742              
1743 23 100       316 if ( !-e $file ) {
1744              
1745 9         291 my ( $base, $path, $suffix ) = fileparse($file);
1746              
1747 9 50 66     236 return $self->error( "is_writable: $path not writable by "
1748             . getpwuid($>)
1749             . "$nl$nl", %args) if (-e $path && !-w $path);
1750 9         43 return 1;
1751             }
1752              
1753 14 50       150 return $self->error( " $file not writable by " . getpwuid($>) . "$nl$nl", frames=>2, %args ) if ! -w $file;
1754              
1755 14         72 $self->audit( "$file is writable" );
1756 14         66 return 1;
1757             }
1758              
1759             sub logfile_append {
1760 3     3 1 29 my $self = shift;
1761 3 50       11 my $file = shift or croak "missing filename!";
1762 3         28 my %p = validate( @_,
1763             { 'lines' => { type => ARRAYREF, optional => 0, },
1764             'prog' => { type => BOOLEAN, optional => 1, default => 0, },
1765             $self->get_std_opts,
1766             },
1767             );
1768              
1769 3         17 my $lines = $p{lines};
1770 3         14 my %args = $self->get_std_args( %p );
1771              
1772 3         15 my ( $dd, $mm, $yy, $lm, $hh, $mn, $ss ) = $self->get_the_date( %args );
1773              
1774 3 50       128 open my $LOG_FILE, '>>', $file
1775             or return $self->error( "couldn't open $file: $OS_ERROR", %args);
1776              
1777 3         21 print $LOG_FILE "$yy-$mm-$dd $hh:$mn:$ss $p{prog} ";
1778              
1779 3         6 my $i;
1780 3         6 foreach (@$lines) { print $LOG_FILE "$_ "; $i++ }
  5         9  
  5         8  
1781              
1782 3         6 print $LOG_FILE "\n";
1783 3         68 close $LOG_FILE;
1784              
1785 3         25 $self->audit( "logfile_append wrote $i lines to $file", %args );
1786 3         21 return 1;
1787             }
1788              
1789             sub mail_toaster {
1790 0     0 0 0 my $self = shift;
1791 0         0 $self->install_module( 'Mail::Toaster' );
1792             }
1793              
1794             sub mkdir_system {
1795 2     2 1 300 my $self = shift;
1796 2         22 my %p = validate(
1797             @_,
1798             { 'dir' => { type => SCALAR, optional => 0, },
1799             'mode' => { type => SCALAR, optional => 1, },
1800             'sudo' => { type => BOOLEAN, optional => 1, default => 0 },
1801             $self->get_std_opts,
1802             }
1803             );
1804              
1805 2         15 my ( $dir, $mode ) = ( $p{dir}, $p{mode} );
1806 2         9 my %args = $self->get_std_args( %p );
1807              
1808 2 50       44 return $self->audit( "mkdir_system: $dir already exists.") if -d $dir;
1809              
1810 2 50       21 my $mkdir = $self->find_bin( 'mkdir', %args) or return;
1811              
1812             # if we are root, just do it (no sudo nonsense)
1813 2 50       22 if ( $< == 0 ) {
1814 2 50       33 $self->syscmd( "$mkdir -p $dir", %args) or return;
1815 2 50       22 $self->chmod( dir => $dir, mode => $mode, %args ) if $mode;
1816              
1817 2 50       96 return 1 if -d $dir;
1818 0         0 return $self->error( "failed to create $dir", %args);
1819             }
1820              
1821 0 0       0 if ( $p{sudo} ) {
1822 0         0 my $sudo = $self->sudo();
1823              
1824 0         0 $self->audit( "trying $sudo $mkdir -p $dir");
1825 0         0 $self->syscmd( "$sudo $mkdir -p $dir", %args);
1826              
1827 0         0 $self->audit( "setting ownership to $<.");
1828 0         0 my $chown = $self->find_bin( 'chown', %args);
1829 0         0 $self->syscmd( "$sudo $chown $< $dir", %args);
1830              
1831 0 0       0 $self->chmod( dir => $dir, mode => $mode, sudo => $sudo, %args)
1832             if $mode;
1833 0 0       0 return -d $dir ? 1 : 0;
1834             }
1835              
1836 0         0 $self->audit( "trying mkdir -p $dir" );
1837              
1838             # no root and no sudo, just try and see what happens
1839 0 0       0 $self->syscmd( "$mkdir -p $dir", %args ) or return;
1840              
1841 0 0       0 $self->chmod( dir => $dir, mode => $mode, %args) if $mode;
1842              
1843 0 0       0 return $self->audit( "mkdir_system created $dir" ) if -d $dir;
1844 0         0 return $self->error( '', %args );
1845             }
1846              
1847             sub check_pidfile {
1848 3     3 1 15 my $self = shift;
1849 3         8 my $file = shift;
1850 3         13 my %p = validate( @_, { $self->get_std_opts } );
1851 3         15 my %args = $self->get_std_args( %p );
1852              
1853 3 50       5 return $self->error( "missing filename", %args) if ! $file;
1854 3 100 100     92 return $self->error( "$file is not a regular file", %args)
1855             if ( -e $file && !-f $file );
1856              
1857             # test if file & enclosing directory is writable, revert to /tmp if not
1858             $self->is_writable( $file, %args)
1859 2 50       12 or do {
1860 0         0 my ( $base, $path, $suffix ) = fileparse($file);
1861 0         0 $self->audit( "NOTICE: using /tmp for file, $path is not writable!", %args);
1862 0         0 $file = "/tmp/$base";
1863             };
1864              
1865             # if it does not exist
1866 2 100       23 if ( !-e $file ) {
1867 1         9 $self->audit( "writing process id $PROCESS_ID to $file...");
1868 1 50       9 $self->file_write( $file, lines => [$PROCESS_ID], %args) and return $file;
1869             };
1870              
1871 1         11 my $age = time() - stat($file)->mtime;
1872              
1873 1 50       203 if ( $age < 1200 ) { # less than 20 minutes old
    0          
1874 1         14 return $self->error( "check_pidfile: $file is " . $age / 60
1875             . " minutes old and might still be running. If it is not running,"
1876             . " please remove the file (rm $file).", %args);
1877             }
1878             elsif ( $age < 3600 ) { # 1 hour
1879 0         0 return $self->error( "check_pidfile: $file is " . $age / 60
1880             . " minutes old and might still be running. If it is not running,"
1881             . " please remove the pidfile. (rm $file)", %args);
1882             }
1883             else {
1884 0         0 $self->audit( "check_pidfile: $file is $age seconds old, ignoring.", %args);
1885             }
1886              
1887 0         0 return $file;
1888             }
1889              
1890             sub parse_config {
1891 8     8 0 553 my $self = shift;
1892 8 50       36 my $file = shift or die "missing file name";
1893 8         58 my %p = validate( @_, {
1894             etcdir => { type=>SCALAR, optional=>1, },
1895             $self->get_std_opts,
1896             },
1897             );
1898              
1899 8         67 my %args = $self->get_std_args( %p );
1900              
1901 8 50       173 if ( ! -f $file ) { $file = $self->find_config( $file, %args ); };
  8         35  
1902              
1903 8 100 66     275 if ( ! $file || ! -r $file ) {
1904 1         9 return $self->error( "could not find config file!", %args);
1905             };
1906              
1907 7         24 my %hash;
1908 7         96 $self->audit( " read config from $file");
1909              
1910 7         51 my @config = $self->file_read( $file );
1911 7         91 foreach ( @config ) {
1912 3139 100       3664 next if ! $_;
1913 2695         1691 chomp;
1914 2695 100       3676 next if $_ =~ /^#/; # skip lines beginning with #
1915 1889 50       3118 next if $_ =~ /^[\s+]?$/; # skip empty lines
1916              
1917 1889         2375 my ( $key, $val ) = $self->parse_line( $_ );
1918              
1919 1889 100       2391 next if ! $key;
1920 1810         3875 $hash{$key} = $val;
1921             }
1922              
1923 7         281 return \%hash;
1924             }
1925              
1926             sub parse_line {
1927 1893     1893 0 2798 my $self = shift;
1928 1893         1191 my $line = shift;
1929 1893         11805 my %p = validate( @_, {
1930             strip => { type => BOOLEAN, optional=>1, default=>1 },
1931             },
1932             );
1933              
1934 1893         3410 my $strip = $p{strip};
1935              
1936             # this regexp must match and return these patterns
1937             # localhost1 = localhost, disk, da0, disk_da0
1938             # hosts = localhost lab.simerson.net seattle.simerson.net
1939              
1940 1893         9309 my ( $key, $val ) = $line =~ /\A
1941             \s* # any amount of leading white space, greedy
1942             (.*?) # all characters, non greedy
1943             \s* # any amount of white space, greedy
1944             =
1945             \s* # same, except on the other side of the =
1946             (.*?)
1947             \s*
1948             \z/xms;
1949              
1950             # remove any comments
1951 1893 100 66     7575 if ( $strip && $val && $val =~ /#/ ) {
      100        
1952              
1953             # removes everything from a # to the right, including
1954             # any spaces to the left of the # symbol.
1955 903         1728 ($val) = $val =~ /(.*?\S)\s*#/;
1956             }
1957              
1958 1893         3393 return ( $key, $val );
1959             }
1960              
1961             sub provision_unix {
1962 0     0 0 0 my $self = shift;
1963 0         0 $self->install_module( 'Provision::Unix' );
1964             }
1965              
1966             sub regexp_test {
1967 1     1 1 292 my $self = shift;
1968 1         10 my %p = validate(
1969             @_,
1970             { 'exp' => { type => SCALAR },
1971             'string' => { type => SCALAR },
1972             'pbp' => { type => BOOLEAN, optional => 1, default => 0 },
1973             $self->get_std_opts,
1974             },
1975             );
1976              
1977 1         7 my $verbose = $p{verbose};
1978 1         2 my ( $exp, $string, $pbp ) = ( $p{exp}, $p{string}, $p{pbp} );
1979              
1980 1 50       5 if ($pbp) {
1981 0 0       0 if ( $string =~ m{($exp)}xms ) {
1982 0 0       0 print "\t Matched pbp: |$`<$&>$'|\n" if $verbose;
1983 0         0 return $1;
1984             }
1985             else {
1986 0 0       0 print "\t No match.\n" if $verbose;
1987 0         0 return;
1988             }
1989             }
1990              
1991 1 50       40 if ( $string =~ m{($exp)} ) {
1992 1 50       6 print "\t Matched: |$`<$&>$'|\n" if $verbose;
1993 1         10 return $1;
1994             }
1995              
1996 0 0       0 print "\t No match.\n" if $verbose;
1997 0         0 return;
1998             }
1999              
2000             sub sources_get {
2001 0     0 1 0 my $self = shift;
2002 0         0 my %p = validate(
2003             @_,
2004             { 'package' => { type => SCALAR, optional => 0 },
2005             site => { type => SCALAR, optional => 0 },
2006             path => { type => SCALAR, optional => 1 },
2007             $self->get_std_opts,
2008             },
2009             );
2010              
2011 0         0 my ( $package, $site, $path ) = ( $p{package}, $p{site}, $p{path} );
2012 0         0 my %args = $self->get_std_args( %p );
2013              
2014 0         0 $self->audit( "sources_get: fetching $package from site $site\n\t path: $path");
2015              
2016 0         0 my @extensions = qw/ tar.gz tgz tar.bz2 tbz2 /;
2017              
2018 0 0       0 my $filet = $self->find_bin( 'file', %args) or return;
2019 0 0       0 my $grep = $self->find_bin( 'grep', %args) or return;
2020              
2021 0         0 foreach my $ext (@extensions) {
2022              
2023 0         0 my $tarball = "$package.$ext";
2024 0 0       0 next if !-e $tarball;
2025 0 0       0 $self->audit( " found $tarball!") if -e $tarball;
2026              
2027 0 0       0 if (`$filet $tarball | $grep compress`) {
2028 0 0       0 $self->yes_or_no( "$tarball exists, shall I use it?: ")
2029             and return $self->audit( " ok, using existing archive: $tarball");
2030             }
2031              
2032 0         0 $self->file_delete( $tarball, %args );
2033             }
2034              
2035 0         0 foreach my $ext (@extensions) {
2036 0         0 my $tarball = "$package.$ext";
2037              
2038 0         0 $self->audit( "sources_get: fetching ".$site . $path.'/'.$tarball);
2039              
2040 0 0       0 $self->get_url( "$site$path/$tarball", fatal => 0)
2041             or return $self->error( "couldn't fetch $site$path/$tarball", %args);
2042              
2043 0 0       0 next if ! -e $tarball;
2044              
2045 0         0 $self->audit( " sources_get: testing $tarball ");
2046              
2047 0 0       0 if (`$filet $tarball | $grep zip`) {
2048 0         0 $self->audit( " sources_get: looks good!");
2049 0         0 return 1;
2050             };
2051              
2052 0         0 $self->audit( " oops, is not [b|g]zipped data!");
2053 0         0 $self->file_delete( $tarball, %args);
2054             }
2055              
2056 0         0 return $self->error( "unable to get $package", %args );
2057             }
2058              
2059             sub source_warning {
2060 1     1 1 2 my $self = shift;
2061 1         14 my %p = validate(
2062             @_,
2063             { 'package' => { type => SCALAR, },
2064             'clean' => { type => BOOLEAN, optional => 1, default => 1 },
2065             'src' => {
2066             type => SCALAR,
2067             optional => 1,
2068             default => "/usr/local/src"
2069             },
2070             'timeout' => { type => SCALAR, optional => 1, default => 60 },
2071             $self->get_std_opts,
2072             },
2073             );
2074              
2075 1         7 my ( $package, $src ) = ( $p{package}, $p{src} );
2076 1         6 my %args = $self->get_std_args( %p );
2077              
2078 1 50       44 return $self->audit( "$package sources not present.", %args ) if !-d $package;
2079              
2080 0 0       0 if ( -e $package ) {
2081 0         0 print "
2082             $package sources are already present, indicating that you've already
2083             installed $package. If you want to reinstall it, remove the existing
2084             sources (rm -r $src/$package) and re-run this script\n\n";
2085 0 0       0 return if !$p{clean};
2086             }
2087              
2088 0 0       0 if ( !$self->yes_or_no( "\n\tMay I remove the sources for you?", timeout => $p{timeout} ) ) {
2089 0         0 print "\nskipping $package install.\n\n";
2090 0         0 return;
2091             };
2092              
2093 0         0 $self->audit( " wd: " . cwd );
2094 0         0 $self->audit( " deleting $src/$package");
2095              
2096 0 0       0 return $self->error( "failed to delete $package: $OS_ERROR", %args )
2097             if ! rmtree "$src/$package";
2098 0         0 return 1;
2099             }
2100              
2101             sub sudo {
2102 1     1 1 2 my $self = shift;
2103 1         4 my %p = validate( @_, { $self->get_std_opts } );
2104              
2105             # if we are running as root via $<
2106 1 50       8 if ( $REAL_USER_ID == 0 ) {
2107 1         4 $self->audit( "sudo: you are root, sudo isn't necessary.");
2108 1         5 return ''; # return an empty string, purposefully
2109             }
2110              
2111 0         0 my $sudo;
2112 0         0 my $path_to_sudo = $self->find_bin( 'sudo', fatal => 0 );
2113              
2114             # sudo is installed
2115 0 0 0     0 if ( $path_to_sudo && -x $path_to_sudo ) {
2116 0         0 $self->audit( "sudo: sudo was found at $path_to_sudo.");
2117 0         0 return "$path_to_sudo -p 'Password for %u@%h:'";
2118             }
2119              
2120 0         0 $self->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 Mail::Toaster may not work as expected without it.\n");
2121              
2122             # try installing sudo
2123 0 0       0 $self->yes_or_no( "may I try to install sudo?", timeout => 20 ) or do {
2124 0         0 print "very well then, skipping along.\n";
2125 0         0 return "";
2126             };
2127              
2128 0 0       0 -x $self->find_bin( "sudo", fatal => 0 ) or
2129             $self->install_from_source(
2130             package => 'sudo-1.6.9p17',
2131             site => 'http://www.courtesan.com',
2132             url => '/sudo/',
2133             targets => [ './configure', 'make', 'make install' ],
2134             patches => '',
2135             verbose => 1,
2136             );
2137              
2138             # can we find it now?
2139 0         0 $path_to_sudo = $self->find_bin( "sudo" );
2140              
2141 0 0       0 if ( !-x $path_to_sudo ) {
2142 0         0 print "sudo install failed!";
2143 0         0 return '';
2144             }
2145              
2146 0         0 return "$path_to_sudo -p 'Password for %u@%h:'";
2147             }
2148              
2149             sub syscmd {
2150 13     13 1 3693 my $self = shift;
2151 13 50       65 my $cmd = shift or die "missing command!\n";
2152 13         125 my %p = validate(
2153             @_,
2154             { 'timeout' => { type => SCALAR, optional => 1 },
2155             $self->get_std_opts,
2156             },
2157             );
2158              
2159 13         97 my %args = $self->get_std_args( %p );
2160              
2161 13         100 $self->audit("syscmd: $cmd");
2162              
2163 13         17 my ( $is_safe, $tainted, $bin, @args );
2164              
2165             # separate the program from its arguments
2166 13 50       140 if ( $cmd =~ m/\s+/xm ) {
2167 13         154 ($cmd) = $cmd =~ /^\s*(.*?)\s*$/; # trim lead/trailing whitespace
2168 13         100 @args = split /\s+/, $cmd; # split on whitespace
2169 13         31 $bin = shift @args;
2170 13         22 $is_safe++;
2171 13         121 $self->audit("\tprogram: $bin, args : " . join ' ', @args, %args);
2172             }
2173             else {
2174             # does not not contain a ./ pattern
2175 0 0       0 if ( $cmd !~ m{\./} ) { $bin = $cmd; $is_safe++; };
  0         0  
  0         0  
2176             }
2177              
2178 13 50 33     110 if ( $is_safe && !$bin ) {
2179 0         0 return $self->error("command is not safe! BAILING OUT!", %args);
2180             }
2181              
2182 13         23 my $message;
2183 13 50       56 $message .= "syscmd: bin is <$bin>" if $bin;
2184 13 50       41 $message .= " (safe)" if $is_safe;
2185 13         47 $self->audit($message, %args );
2186              
2187 13 100 66     276 if ( $bin && !-e $bin ) { # $bin is set, but we have not found it
2188 5 50       30 $bin = $self->find_bin( $bin, fatal => 0, verbose => 0 )
2189             or return $self->error( "$bin was not found", %args);
2190             }
2191 13         38 unshift @args, $bin;
2192              
2193 13         141 require Scalar::Util;
2194 13 50       61 $tainted++ if Scalar::Util::tainted($cmd);
2195              
2196 13         54 my $before_path = $ENV{PATH};
2197              
2198             # instead of croaking, maybe try setting a
2199             # very restrictive PATH? I'll err on the side of safety
2200             # $ENV{PATH} = '';
2201 13 50 33     62 return $self->error( "syscmd request has tainted data", %args)
2202             if ( $tainted && !$is_safe );
2203              
2204 13 50       33 if ($is_safe) {
2205 13         23 my $prefix = "/usr/local"; # restrict the path
2206 13 50       114 $prefix = "/opt/local" if -d "/opt/local";
2207 13         89 $ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin:$prefix/bin:$prefix/sbin";
2208             }
2209              
2210 13         20 my $r;
2211 13         36 eval {
2212 13 100       39 if ( defined $p{timeout} ) {
2213 1     0   53 local $SIG{ALRM} = sub { die "alarm\n" };
  0         0  
2214 1         31 alarm $p{timeout};
2215             };
2216             #$r = system $cmd;
2217 13         236530 $r = `$cmd 2>&1`;
2218 13 100       203 alarm 0 if defined $p{timeout};
2219             };
2220              
2221 13 50       53 if ($EVAL_ERROR) {
2222 0 0       0 if ( $EVAL_ERROR eq "alarm\n" ) {
2223 0         0 $self->audit("timed out");
2224             }
2225             else {
2226 0         0 return $self->error( "unknown error '$EVAL_ERROR'", %args);
2227             }
2228             }
2229 13         146 $ENV{PATH} = $before_path; # set PATH back to original value
2230              
2231 13         150 my @caller = caller;
2232 13         153 return $self->syscmd_exit_code( $r, $CHILD_ERROR, \@caller, \%args );
2233             }
2234              
2235             sub syscmd_exit_code {
2236 13     13 0 45 my $self = shift;
2237 13         82 my ($r, $err, $caller, $args) = @_;
2238              
2239 13         156 $self->audit( "r: $r" );
2240              
2241 13         205 my $exit_code = sprintf ("%d", $err >> 8);
2242 13 100       279 return 1 if $exit_code == 0; # success
2243              
2244             #print 'error # ' . $ERRNO . "\n"; # $! == $ERRNO
2245 4         42 $self->error( "$err: $r",fatal=>0);
2246              
2247 4 50       25 if ( $err == -1 ) { # check $? for "normal" errors
    50          
2248 0         0 $self->error( "failed to execute: $ERRNO", fatal=>0);
2249             }
2250             elsif ( $err & 127 ) { # check for core dump
2251 0 0       0 printf "child died with signal %d, %s coredump\n", ( $? & 127 ),
2252             ( $? & 128 ) ? 'with' : 'without';
2253             }
2254              
2255 4         36 return $self->error( "$err: $r", location => join( ", ", @$caller ), %$args );
2256             };
2257              
2258             sub yes_or_no {
2259 1     1 1 3 my $self = shift;
2260 1         2 my $question = shift;
2261 1         9 my %p = validate(
2262             @_,
2263             { 'timeout' => { type => SCALAR, optional => 1 },
2264             'force' => { type => BOOLEAN, optional => 1, default => 0 },
2265             $self->get_std_opts
2266             },
2267             );
2268              
2269              
2270             # for 'make test' testing
2271 1 50       14 return 1 if $question eq "test";
2272              
2273             # force if interactivity testing is not working properly.
2274 0 0 0     0 if ( !$p{force} && !$self->is_interactive ) {
2275 0         0 carp "not running interactively, can't prompt!";
2276 0         0 return;
2277             }
2278              
2279 0         0 my $response;
2280              
2281 0 0       0 print "\nYou have $p{timeout} seconds to respond.\n" if $p{timeout};
2282 0         0 print "\n\t\t$question";
2283              
2284             # I wish I knew why this is not working correctly
2285             # eval { local $SIG{__DIE__}; require Term::ReadKey };
2286             # if ($@) { #
2287             # require Term::ReadKey;
2288             # Term::ReadKey->import();
2289             # print "yay, Term::ReadKey is present! Are you pleased? (y/n):\n";
2290             # use Term::Readkey;
2291             # ReadMode 4;
2292             # while ( not defined ($key = ReadKey(-1)))
2293             # { # no key yet }
2294             # print "Got key $key\n";
2295             # ReadMode 0;
2296             # };
2297              
2298 0 0       0 if ( $p{timeout} ) {
2299 0         0 eval {
2300 0     0   0 local $SIG{ALRM} = sub { die "alarm\n" };
  0         0  
2301 0         0 alarm $p{timeout};
2302 0   0     0 do {
2303 0         0 print "(y/n): ";
2304 0         0 $response = lc(<STDIN>);
2305 0         0 chomp($response);
2306             } until ( $response eq "n" || $response eq "y" );
2307 0         0 alarm 0;
2308             };
2309              
2310 0 0       0 if ($@) {
2311 0 0       0 $@ eq "alarm\n" ? print "timed out!\n" : carp;
2312             }
2313              
2314 0 0 0     0 return ($response && $response eq "y") ? 1 : 0;
2315             }
2316              
2317 0   0     0 do {
2318 0         0 print "(y/n): ";
2319 0         0 $response = lc(<STDIN>);
2320 0         0 chomp($response);
2321             } until ( $response eq "n" || $response eq "y" );
2322              
2323 0 0       0 return ($response eq "y") ? 1 : 0;
2324             }
2325              
2326             1;
2327             __END__
2328             sub {}; # for vim autofold
2329              
2330              
2331             =head1 SYNOPSIS
2332              
2333             use Mail::Toaster::Utility;
2334             my $toaster = Mail::Toaster::Utility->new;
2335              
2336             $util->file_write($file, lines=> @lines);
2337              
2338             This is just one of the many handy little methods I have amassed here. Rather than try to remember all of the best ways to code certain functions and then attempt to remember them, I have consolidated years of experience and countless references from Learning Perl, Programming Perl, Perl Best Practices, and many other sources into these subroutines.
2339              
2340              
2341             =head1 DESCRIPTION
2342              
2343             This Mail::Toaster::Utility package is my most frequently used one. Each method has its own documentation but in general, all methods accept as input a hashref with at least one required argument and a number of optional arguments.
2344              
2345              
2346             =head1 DIAGNOSTICS
2347              
2348             All methods set and return error codes (0 = fail, 1 = success) unless otherwise stated.
2349              
2350             Unless otherwise mentioned, all methods accept two additional parameters:
2351              
2352             verbose - to print status and verbose error messages, set verbose=>1.
2353             fatal - die on errors. This is the default, set fatal=>0 to override.
2354              
2355              
2356             =head1 DEPENDENCIES
2357              
2358             Perl.
2359             Scalar::Util - built-in as of perl 5.8
2360              
2361             Almost nothing else. A few of the methods do require certian things, like extract_archive requires tar and file. But in general, this package (Mail::Toaster::Utility) should run flawlessly on any UNIX-like system. Because I recycle this package in other places (not just Mail::Toaster), I avoid creating dependencies here.
2362              
2363             =head1 METHODS
2364              
2365             =over
2366              
2367              
2368             =item new
2369              
2370             To use any of the methods below, you must first create a utility object. The methods can be accessed via the utility object.
2371              
2372             ############################################
2373             # Usage : use Mail::Toaster::Utility;
2374             # : my $util = Mail::Toaster::Utility->new;
2375             # Purpose : create a new Mail::Toaster::Utility object
2376             # Returns : a bona fide object
2377             # Parameters : none
2378             ############################################
2379              
2380              
2381             =item ask
2382              
2383              
2384             Get a response from the user. If the user responds, their response is returned. If not, then the default response is returned. If no default was supplied, 0 is returned.
2385              
2386             ############################################
2387             # Usage : my $ask = $util->ask( "Would you like fries with that",
2388             # default => "SuperSized!",
2389             # timeout => 30
2390             # );
2391             # Purpose : prompt the user for information
2392             #
2393             # Returns : S - the users response (if not empty) or
2394             # : S - the default ask or
2395             # : S - an empty string
2396             #
2397             # Parameters
2398             # Required : S - question - what to ask
2399             # Optional : S - default - a default answer
2400             # : I - timeout - how long to wait for a response
2401             # Throws : no exceptions
2402             # See Also : yes_or_no
2403              
2404              
2405             =item extract_archive
2406              
2407              
2408             Decompresses a variety of archive formats using your systems built in tools.
2409              
2410             ############### extract_archive ##################
2411             # Usage : $util->extract_archive( 'example.tar.bz2' );
2412             # Purpose : test the archiver, determine its contents, and then
2413             # use the best available means to expand it.
2414             # Returns : 0 - failure, 1 - success
2415             # Parameters : S - archive - a bz2, gz, or tgz file to decompress
2416              
2417              
2418             =item cwd_source_dir
2419              
2420              
2421             Changes the current working directory to the supplied one. Creates it if it does not exist. Tries to create the directory using perl's builtin mkdir, then the system mkdir, and finally the system mkdir with sudo.
2422              
2423             ############ cwd_source_dir ###################
2424             # Usage : $util->cwd_source_dir( "/usr/local/src" );
2425             # Purpose : prepare a location to build source files in
2426             # Returns : 0 - failure, 1 - success
2427             # Parameters : S - dir - a directory to build programs in
2428              
2429              
2430             =item check_homedir_ownership
2431              
2432             Checks the ownership on all home directories to see if they are owned by their respective users in /etc/password. Offers to repair the permissions on incorrectly owned directories. This is useful when someone that knows better does something like "chown -R user /home /user" and fouls things up.
2433              
2434             ######### check_homedir_ownership ############
2435             # Usage : $util->check_homedir_ownership();
2436             # Purpose : repair user homedir ownership
2437             # Returns : 0 - failure, 1 - success
2438             # Parameters :
2439             # Optional : I - auto - no prompts, just fix everything
2440             # See Also : sysadmin
2441              
2442             Comments: Auto mode should be run with great caution. Run it first to see the results and then, if everything looks good, run in auto mode to do the actual repairs.
2443              
2444              
2445             =item chown_system
2446              
2447             The advantage this sub has over a Pure Perl implementation is that it can utilize sudo to gain elevated permissions that we might not otherwise have.
2448              
2449              
2450             ############### chown_system #################
2451             # Usage : $util->chown_system( dir=>"/tmp/example", user=>'matt' );
2452             # Purpose : change the ownership of a file or directory
2453             # Returns : 0 - failure, 1 - success
2454             # Parameters : S - dir - the directory to chown
2455             # : S - user - a system username
2456             # Optional : S - group - a sytem group name
2457             # : I - recurse - include all files/folders in directory?
2458             # Comments : Uses the system chown binary
2459             # See Also : n/a
2460              
2461              
2462             =item clean_tmp_dir
2463              
2464              
2465             ############## clean_tmp_dir ################
2466             # Usage : $util->clean_tmp_dir( $dir );
2467             # Purpose : clean up old build stuff before rebuilding
2468             # Returns : 0 - failure, 1 - success
2469             # Parameters : S - $dir - a directory or file.
2470             # Throws : die on failure
2471             # Comments : Running this will delete its contents. Be careful!
2472              
2473              
2474             =item get_mounted_drives
2475              
2476             ############# get_mounted_drives ############
2477             # Usage : my $mounts = $util->get_mounted_drives();
2478             # Purpose : Uses mount to fetch a list of mounted drive/partitions
2479             # Returns : a hashref of mounted slices and their mount points.
2480              
2481              
2482             =item archive_file
2483              
2484              
2485             ############### archive_file #################
2486             # Purpose : Make a backup copy of a file by copying the file to $file.timestamp.
2487             # Usage : my $archived_file = $util->archive_file( $file );
2488             # Returns : the filename of the backup file, or 0 on failure.
2489             # Parameters : S - file - the filname to be backed up
2490             # Comments : none
2491              
2492              
2493             =item chmod
2494              
2495             Set the permissions (ugo-rwx) of a file. Will use the native perl methods (by default) but can also use system calls and prepend sudo if additional permissions are needed.
2496              
2497             $util->chmod(
2498             file_or_dir => '/etc/resolv.conf',
2499             mode => '0755',
2500             sudo => $sudo
2501             )
2502              
2503             arguments required:
2504             file_or_dir - a file or directory to alter permission on
2505             mode - the permissions (numeric)
2506              
2507             arguments optional:
2508             sudo - the output of $util->sudo
2509              
2510             result:
2511             0 - failure
2512             1 - success
2513              
2514              
2515             =item chown
2516              
2517             Set the ownership (user and group) of a file. Will use the native perl methods (by default) but can also use system calls and prepend sudo if additional permissions are needed.
2518              
2519             $util->chown(
2520             file_or_dir => '/etc/resolv.conf',
2521             uid => 'root',
2522             gid => 'wheel',
2523             sudo => 1
2524             );
2525              
2526             arguments required:
2527             file_or_dir - a file or directory to alter permission on
2528             uid - the uid or user name
2529             gid - the gid or group name
2530              
2531             arguments optional:
2532             file - alias for file_or_dir
2533             dir - alias for file_or_dir
2534             sudo - the output of $util->sudo
2535              
2536             result:
2537             0 - failure
2538             1 - success
2539              
2540              
2541             =item file_delete
2542              
2543             ############################################
2544             # Usage : $util->file_delete( $file );
2545             # Purpose : Deletes a file.
2546             # Returns : 0 - failure, 1 - success
2547             # Parameters
2548             # Required : file - a file path
2549             # Comments : none
2550             # See Also :
2551              
2552             Uses unlink if we have appropriate permissions, otherwise uses a system rm call, using sudo if it is not being run as root. This sub will try very hard to delete the file!
2553              
2554              
2555             =item get_url
2556              
2557             $util->get_url( $url, verbose=>1 );
2558              
2559             Use the standard URL fetching utility (fetch, curl, wget) for your OS to download a file from the $url handed to us.
2560              
2561             arguments required:
2562             url - the fully qualified URL
2563              
2564             arguments optional:
2565             timeout - the maximum amount of time to try
2566              
2567             result:
2568             1 - success
2569             0 - failure
2570              
2571              
2572             =item file_is_newer
2573              
2574             compares the mtime on two files to determine if one is newer than another.
2575              
2576              
2577             =item file_mode
2578              
2579             usage:
2580             my @lines = "1", "2", "3"; # named array
2581             $util->file_write ( "/tmp/foo", lines=>\@lines );
2582             or
2583             $util->file_write ( "/tmp/foo", lines=>['1','2','3'] ); # anon arrayref
2584              
2585             required arguments:
2586             mode - the files permissions mode
2587              
2588             result:
2589             0 - failure
2590             1 - success
2591              
2592              
2593             =item file_read
2594              
2595             Reads in a file, and returns it in an array. All lines in the array are chomped.
2596              
2597             my @lines = $util->file_read( $file, max_lines=>100 )
2598              
2599             arguments required:
2600             file - the file to read in
2601              
2602             arguments optional:
2603             max_lines - integer - max number of lines
2604             max_length - integer - maximum length of a line
2605              
2606             result:
2607             0 - failure
2608             success - returns an array with the files contents, one line per array element
2609              
2610              
2611             =item file_write
2612              
2613             usage:
2614             my @lines = "1", "2", "3"; # named array
2615             $util->file_write ( "/tmp/foo", lines=>\@lines );
2616             or
2617             $util->file_write ( "/tmp/foo", lines=>['1','2','3'] ); # anon arrayref
2618              
2619             required arguments:
2620             file - the file path you want to write to
2621             lines - an arrayref. Each array element will be a line in the file
2622              
2623             result:
2624             0 - failure
2625             1 - success
2626              
2627              
2628             =item files_diff
2629              
2630             Determine if the files are different. $type is assumed to be text unless you set it otherwise. For anthing but text files, we do a MD5 checksum on the files to determine if they are different or not.
2631              
2632             $util->files_diff( f1=>$file1,f2=>$file2,type=>'text',verbose=>1 );
2633              
2634             if ( $util->files_diff( f1=>"foo", f2=>"bar" ) )
2635             {
2636             print "different!\n";
2637             };
2638              
2639             required arguments:
2640             f1 - the first file to compare
2641             f2 - the second file to compare
2642              
2643             arguments optional:
2644             type - the type of file (text or binary)
2645              
2646             result:
2647             0 - files are the same
2648             1 - files are different
2649             -1 - error.
2650              
2651              
2652             =item find_bin
2653              
2654             Check all the "normal" locations for a binary that should be on the system and returns the full path to the binary.
2655              
2656             $util->find_bin( 'dos2unix', dir=>'/opt/local/bin' );
2657              
2658             Example:
2659              
2660             my $sudo = $util->find_bin( "sudo", dir => "/usr/local/sbin" );
2661              
2662              
2663             arguments required:
2664             bin - the name of the program (its filename)
2665              
2666             arguments optional:
2667             dir - a directory to check first
2668              
2669             results:
2670             0 - failure
2671             success will return the full path to the binary.
2672              
2673              
2674             =item find_config
2675              
2676             This sub is called by several others to determine which configuration file to use. The general logic is as follows:
2677              
2678             If the etc dir and file name are provided and the file exists, use it.
2679              
2680             If that fails, then go prowling around the drive and look in all the usual places, in order of preference:
2681              
2682             /opt/local/etc/
2683             /usr/local/etc/
2684             /etc
2685              
2686             Finally, if none of those work, then check the working directory for the named .conf file, or a .conf-dist.
2687              
2688             Example:
2689             my $twconf = $util->find_config ( 'toaster-watcher.conf',
2690             etcdir => '/usr/local/etc',
2691             )
2692              
2693             arguments required:
2694             file - the .conf file to read in
2695              
2696             arguments optional:
2697             etcdir - the etc directory to prefer
2698              
2699             result:
2700             0 - failure
2701             the path to $file
2702              
2703              
2704             =item get_my_ips
2705              
2706             returns an arrayref of IP addresses on local interfaces.
2707              
2708             =item is_process_running
2709              
2710             Verify if a process is running or not.
2711              
2712             $util->is_process_running($process) ? print "yes" : print "no";
2713              
2714             $process is the name as it would appear in the process table.
2715              
2716              
2717              
2718             =item is_readable
2719              
2720              
2721             ############################################
2722             # Usage : $util->is_readable( file=>$file );
2723             # Purpose : ????
2724             # Returns : 0 = no (not reabable), 1 = yes
2725             # Parameters : S - file - a path name to a file
2726             # Throws : no exceptions
2727             # Comments : none
2728             # See Also : n/a
2729              
2730             result:
2731             0 - no (file is not readable)
2732             1 - yes (file is readable)
2733              
2734              
2735              
2736             =item is_writable
2737              
2738             If the file exists, it checks to see if it is writable. If the file does not exist, it checks to see if the enclosing directory is writable.
2739              
2740             ############################################
2741             # Usage : $util->is_writable( "/tmp/boogers");
2742             # Purpose : make sure a file is writable
2743             # Returns : 0 - no (not writable), 1 - yes (is writeable)
2744             # Parameters : S - file - a path name to a file
2745             # Throws : no exceptions
2746              
2747              
2748             =item fstab_list
2749              
2750              
2751             ############ fstab_list ###################
2752             # Usage : $util->fstab_list;
2753             # Purpose : Fetch a list of drives that are mountable from /etc/fstab.
2754             # Returns : an arrayref
2755             # Comments : used in backup.pl
2756             # See Also : n/a
2757              
2758              
2759             =item get_dir_files
2760              
2761             $util->get_dir_files( $dir, verbose=>1 )
2762              
2763             required arguments:
2764             dir - a directory
2765              
2766             result:
2767             an array of files names contained in that directory.
2768             0 - failure
2769              
2770              
2771             =item get_the_date
2772              
2773             Returns the date split into a easy to work with set of strings.
2774              
2775             $util->get_the_date( bump=>$bump, verbose=>$verbose )
2776              
2777             required arguments:
2778             none
2779              
2780             optional arguments:
2781             bump - the offset (in days) to subtract from the date.
2782              
2783             result: (array with the following elements)
2784             $dd = day
2785             $mm = month
2786             $yy = year
2787             $lm = last month
2788             $hh = hours
2789             $mn = minutes
2790             $ss = seconds
2791              
2792             my ($dd, $mm, $yy, $lm, $hh, $mn, $ss) = $util->get_the_date();
2793              
2794              
2795             =item install_from_source
2796              
2797             usage:
2798              
2799             $util->install_from_source(
2800             package => 'simscan-1.07',
2801             site => 'http://www.inter7.com',
2802             url => '/simscan/',
2803             targets => ['./configure', 'make', 'make install'],
2804             patches => '',
2805             verbose => 1,
2806             );
2807              
2808             Downloads and installs a program from sources.
2809              
2810             required arguments:
2811             conf - hashref - mail-toaster.conf settings.
2812             site -
2813             url -
2814             package -
2815              
2816             optional arguments:
2817             targets - arrayref - defaults to [./configure, make, make install].
2818             patches - arrayref - patch(es) to apply to the sources before compiling
2819             patch_args -
2820             source_sub_dir - a subdirectory within the sources build directory
2821             bintest - check the usual places for an executable binary. If found, it will assume the software is already installed and require confirmation before re-installing.
2822              
2823             result:
2824             1 - success
2825             0 - failure
2826              
2827              
2828             =item install_from_source_php
2829              
2830             Downloads a PHP program and installs it. This function is not completed due to lack o interest.
2831              
2832              
2833             =item is_interactive
2834              
2835             tests to determine if the running process is attached to a terminal.
2836              
2837              
2838             =item logfile_append
2839              
2840             $util->logfile_append( $file, lines=>\@lines )
2841              
2842             Pass a filename and an array ref and it will append a timestamp and the array contents to the file. Here's a working example:
2843              
2844             $util->logfile_append( $file, prog=>"proggy", lines=>["Starting up", "Shutting down"] )
2845              
2846             That will append a line like this to the log file:
2847              
2848             2004-11-12 23:20:06 proggy Starting up
2849             2004-11-12 23:20:06 proggy Shutting down
2850              
2851             arguments required:
2852             file - the log file to append to
2853             prog - the name of the application
2854             lines - arrayref - elements are events to log.
2855              
2856             result:
2857             1 - success
2858             0 - failure
2859              
2860              
2861             =item mailtoaster
2862              
2863             $util->mailtoaster();
2864              
2865             Downloads and installs Mail::Toaster.
2866              
2867              
2868             =item mkdir_system
2869              
2870             $util->mkdir_system( dir => $dir, verbose=>$verbose );
2871              
2872             creates a directory using the system mkdir binary. Can also make levels of directories (-p) and utilize sudo if necessary to escalate.
2873              
2874              
2875             =item check_pidfile
2876              
2877             check_pidfile is a process management method. It will check to make sure an existing pidfile does not exist and if not, it will create the pidfile.
2878              
2879             $pidfile = $util->check_pidfile( "/var/run/program.pid" );
2880              
2881             The above example is all you need to do to add process checking (avoiding multiple daemons running at the same time) to a program or script. This is used in toaster-watcher.pl. toaster-watcher normally completes a run in a few seconds and is run every 5 minutes.
2882              
2883             However, toaster-watcher can be configured to do things like expire old messages from maildirs and feed spam through a processor like sa-learn. This can take a long time on a large mail system so we don't want multiple instances of toaster-watcher running.
2884              
2885             result:
2886             the path to the pidfile (on success).
2887              
2888             Example:
2889              
2890             my $pidfile = $util->check_pidfile( "/var/run/changeme.pid" );
2891             unless ($pidfile) {
2892             warn "WARNING: couldn't create a process id file!: $!\n";
2893             exit 0;
2894             };
2895              
2896             do_a_bunch_of_cool_stuff;
2897             unlink $pidfile;
2898              
2899              
2900             =item regexp_test
2901              
2902             Prints out a string with the regexp match bracketed. Credit to Damien Conway from Perl Best Practices.
2903              
2904             Example:
2905             $util->regexp_test(
2906             exp => 'toast',
2907             string => 'mailtoaster rocks',
2908             );
2909              
2910             arguments required:
2911             exp - the regular expression
2912             string - the string you are applying the regexp to
2913              
2914             result:
2915             printed string highlighting the regexp match
2916              
2917              
2918             =item source_warning
2919              
2920             Checks to see if the old build sources are present. If they are, offer to remove them.
2921              
2922             Usage:
2923              
2924             $util->source_warning(
2925             package => "Mail-Toaster-5.26",
2926             clean => 1,
2927             src => "/usr/local/src"
2928             );
2929              
2930             arguments required:
2931             package - the name of the packages directory
2932              
2933             arguments optional:
2934             src - the source directory to build in (/usr/local/src)
2935             clean - do we try removing the existing sources? (enabled)
2936             timeout - how long to wait for an answer (60 seconds)
2937              
2938             result:
2939             1 - removed
2940             0 - failure, package exists and needs to be removed.
2941              
2942              
2943             =item sources_get
2944              
2945             Tries to download a set of sources files from the site and url provided. It will try first fetching a gzipped tarball and if that files, a bzipped tarball. As new formats are introduced, I will expand the support for them here.
2946              
2947             usage:
2948             $self->sources_get(
2949             package => 'simscan-1.07',
2950             site => 'http://www.inter7.com',
2951             path => '/simscan/',
2952             )
2953              
2954             arguments required:
2955             package - the software package name
2956             site - the host to fetch it from
2957             url - the path to the package on $site
2958              
2959             arguments optional:
2960             conf - hashref - values from toaster-watcher.conf
2961              
2962             This sub proved quite useful during 2005 as many packages began to be distributed in bzip format instead of the traditional gzip.
2963              
2964              
2965             =item sudo
2966              
2967             my $sudo = $util->sudo();
2968              
2969             $util->syscmd( "$sudo rm /etc/root-owned-file" );
2970              
2971             Often you want to run a script as an unprivileged user. However, the script may need elevated privileges for a plethora of reasons. Rather than running the script suid, or as root, configure sudo allowing the script to run system commands with appropriate permissions.
2972              
2973             If sudo is not installed and you're running as root, it'll offer to install sudo for you. This is recommended, as is properly configuring sudo.
2974              
2975             arguments required:
2976              
2977             result:
2978             0 - failure
2979             on success, the full path to the sudo binary
2980              
2981              
2982             =item syscmd
2983              
2984             Just a little wrapper around system calls, that returns any failure codes and prints out the error(s) if present. A bit of sanity testing is also done to make sure the command to execute is safe.
2985              
2986             my $r = $util->syscmd( "gzip /tmp/example.txt" );
2987             $r ? print "ok!\n" : print "not ok.\n";
2988              
2989             arguments required:
2990             cmd - the command to execute
2991              
2992             result
2993             the exit status of the program you called.
2994              
2995              
2996             =item _try_mkdir
2997              
2998             try creating a directory using perl's builtin mkdir.
2999              
3000              
3001             =item yes_or_no
3002              
3003             my $r = $util->yes_or_no(
3004             "Would you like fries with that?",
3005             timeout => 30
3006             );
3007              
3008             $r ? print "fries are in the bag\n" : print "no fries!\n";
3009              
3010             arguments required:
3011             none.
3012              
3013             arguments optional:
3014             question - the question to ask
3015             timeout - how long to wait for an answer (in seconds)
3016              
3017             result:
3018             0 - negative (or null)
3019             1 - success (affirmative)
3020              
3021              
3022             =back
3023              
3024              
3025             =head1 TODO
3026              
3027             make all errors raise exceptions
3028             write test cases for every method
3029              
3030             =head1 SEE ALSO
3031              
3032             The following are all man/perldoc pages:
3033              
3034             Mail::Toaster
3035              
3036              
3037             =cut