Apache-Logmonster
view release on metacpan or search on metacpan
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
package Apache::Logmonster::Utility;
# ABSTRACT: utility subroutines for sysadmin tasks
use strict;
use warnings;
our $VERSION = '5.36';
use Cwd;
use Carp;
use English qw( -no_match_vars );
use File::Basename;
use File::Copy;
use File::Path;
use File::Spec;
use File::stat;
use Params::Validate qw(:all);
use Scalar::Util qw( openhandle );
use URI;
use lib 'lib';
use vars qw/ $log %std_opts /;
sub new {
my $class = shift;
# globally scoped hash, populated with defaults as requested by the caller
%std_opts = (
'fatal' => { type => BOOLEAN, optional => 1, default => 1 },
'debug' => { type => BOOLEAN, optional => 1, default => 1 },
'quiet' => { type => BOOLEAN, optional => 1, default => 0 },
'test_ok' => { type => BOOLEAN, optional => 1 },
);
my %p = validate( @_,
{ toaster=> { type => OBJECT, optional => 1 },
%std_opts,
}
);
my $toaster = $p{toaster};
my $self = {
debug => $p{debug},
fatal => $p{fatal},
};
bless $self, $class;
$log = $self->{log} = $self;
$log->audit( $class . sprintf( " loaded by %s, %s, %s", caller ) );
return $self;
}
sub ask {
my $self = shift;
my $question = shift;
my %p = validate(
@_,
{ default => { type => SCALAR|UNDEF, optional => 1 },
timeout => { type => SCALAR, optional => 1 },
password => { type => BOOLEAN, optional => 1, default => 0 },
test_ok => { type => BOOLEAN, optional => 1 },
}
);
my $pass = $p{password};
my $default = $p{default};
if ( ! $self->is_interactive() ) {
$log->audit( "not running interactively, can not prompt!");
return $default;
}
return $log->error( "ask called with \'$question\' which looks unsafe." )
if $question !~ m{\A \p{Any}* \z}xms;
my $response;
return $p{test_ok} if defined $p{test_ok};
PROMPT:
print "Please enter $question";
print " [$default]" if ( $default && !$pass );
print ": ";
system "stty -echo" if $pass;
if ( $p{timeout} ) {
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm $p{timeout};
$response = <STDIN>;
alarm 0;
};
if ($EVAL_ERROR) {
$EVAL_ERROR eq "alarm\n" ? print "timed out!\n" : warn;
}
}
else {
$response = <STDIN>;
}
if ( $pass ) {
print "Please enter $question (confirm): ";
my $response2 = <STDIN>;
unless ( $response eq $response2 ) {
print "\nPasswords don't match, try again.\n";
goto PROMPT;
}
system "stty echo";
print "\n";
}
chomp $response;
return $response if $response; # if they typed something, return it
return $default if $default; # return the default, if available
return ''; # return empty handed
}
sub audit {
my $self = shift;
my $mess = shift;
my %p = validate( @_, { %std_opts } );
if ($mess) {
push @{ $log->{audit} }, $mess;
print "$mess\n" if $self->{debug} || $p{debug};
}
return \$log->{audit};
}
sub archive_file {
my $self = shift;
my $file = shift or return $log->error("missing filename in request");
my %p = validate( @_,
{ 'sudo' => { type => BOOLEAN, optional => 1, default => 1 },
'mode' => { type => SCALAR, optional => 1 },
destdir => { type => SCALAR, optional => 1 },
%std_opts,
}
);
my %args = $self->get_std_args( %p );
return $log->error( "file ($file) is missing!", %args )
if !-e $file;
my $archive = $file . '.' . time;
if ( $p{destdir} && -d $p{destdir} ) {
my ($vol,$dirs,$file_wo_path) = File::Spec->splitpath( $archive );
$archive = File::Spec->catfile( $p{destdir}, $file_wo_path );
};
# see if we can write to both files (new & archive) with current user
if ( $self->is_writable( $file, %args )
&& $self->is_writable( $archive, %args ) ) {
# we have permission, use perl's native copy
copy( $file, $archive );
if ( -e $archive ) {
$log->audit("archive_file: $file backed up to $archive");
$self->chmod( file => $file, mode => $p{mode}, %args ) if $p{mode};
return $archive;
};
}
# we failed with existing permissions, try to escalate
$self->archive_file_sudo( $file ) if ( $p{sudo} && $< != 0 );
return $log->error( "backup of $file to $archive failed: $!", %args)
if ! -e $archive;
$self->chmod( file => $file, mode => $p{mode}, %args ) if $p{mode};
$log->audit("$file backed up to $archive");
return $archive;
}
sub archive_file_sudo {
my $self = shift;
my ($file, $archive) = @_;
my $sudo = $self->sudo();
my $cp = $self->find_bin( 'cp',fatal=>0 );
if ( $sudo && $cp ) {
return $self->syscmd( "$sudo $cp $file $archive",fatal=>0 );
}
$log->error( "archive_file: sudo or cp was missing, could not escalate.",fatal=>0);
return;
};
sub chmod {
my $self = shift;
my %p = validate(
@_,
{ 'file' => { type => SCALAR, optional => 1, },
'file_or_dir' => { type => SCALAR, optional => 1, },
'dir' => { type => SCALAR, optional => 1, },
'mode' => { type => SCALAR, optional => 0, },
'sudo' => { type => BOOLEAN, optional => 1, default => 0 },
%std_opts,
}
);
my $mode = $p{mode};
my %args = $self->get_std_args( %p );
my $file = $p{file} || $p{file_or_dir} || $p{dir}
or return $log->error( "invalid params to chmod in ". ref $self );
if ( $p{sudo} ) {
my $chmod = $self->find_bin( 'chmod', debug => 0 );
my $sudo = $self->sudo();
$self->syscmd( "$sudo $chmod $mode $file", debug => 0 )
or return $log->error( "couldn't chmod $file: $!", %args );
}
# note the conversion of ($mode) to an octal value. Very important!
CORE::chmod( oct($mode), $file ) or
return $log->error( "couldn't chmod $file: $!", %args);
$log->audit("chmod $mode $file");
}
sub chown {
my $self = shift;
my $file = shift;
my %p = validate( @_,
{ 'uid' => { type => SCALAR },
'gid' => { type => SCALAR },
'sudo' => { type => BOOLEAN, optional => 1 },
%std_opts,
}
);
my %args = $self->get_std_args( %p );
my ( $uid, $gid, $sudo ) = ( $p{uid}, $p{gid}, $p{sudo} );
$file or return $log->error( "missing file or dir", %args );
return $log->error( "file $file does not exist!", %args ) if ! -e $file;
$log->audit("chown: preparing to chown $uid $file");
# sudo forces system chown instead of the perl builtin
return $self->chown_system( $file,
%args,
user => $uid,
group => $gid,
) if $sudo;
my ( $nuid, $ngid ); # if uid or gid is not numeric, convert it
if ( $uid =~ /\A[0-9]+\z/ ) {
$nuid = int($uid);
$log->audit(" using $nuid from int($uid)");
}
else {
$nuid = getpwnam($uid);
return $log->error( "failed to get uid for $uid", %args) if ! defined $nuid;
$log->audit(" converted $uid to a number: $nuid");
}
if ( $gid =~ /\A[0-9\-]+\z/ ) {
$ngid = int( $gid );
$log->audit(" using $ngid from int($gid)");
}
else {
$ngid = getgrnam( $gid );
return $log->error( "failed to get gid for $gid", %args) if ! defined $ngid;
$log->audit(" converted $gid to numeric: $ngid");
}
chown( $nuid, $ngid, $file )
or return $log->error( "couldn't chown $file: $!",%args);
return 1;
}
sub chown_system {
my $self = shift;
my $dir = shift;
my %p = validate( @_,
{ 'user' => { type => SCALAR, optional => 0, },
'group' => { type => SCALAR, optional => 1, },
'recurse' => { type => BOOLEAN, optional => 1, },
%std_opts,
}
);
my ( $user, $group, $recurse ) = ( $p{user}, $p{group}, $p{recurse} );
my %args = $self->get_std_args( %p );
$dir or return $log->error( "missing file or dir", %args );
my $cmd = $self->find_bin( 'chown', %args );
$cmd .= " -R" if $recurse;
$cmd .= " $user";
$cmd .= ":$group" if $group;
$cmd .= " $dir";
$log->audit( "cmd: $cmd" );
$self->syscmd( $cmd, %args ) or
return $log->error( "couldn't chown with $cmd: $!", %args);
my $mess;
$mess .= "Recursively " if $recurse;
$mess .= "changed $dir to be owned by $user";
$log->audit( $mess );
return 1;
}
sub clean_tmp_dir {
my $self = shift;
my $dir = shift or die "missing dir name";
my %p = validate( @_, { %std_opts } );
my %args = $self->get_std_args( %p );
my $before = cwd; # remember where we started
return $log->error( "couldn't chdir to $dir: $!", %args) if !chdir $dir;
foreach ( $self->get_dir_files( $dir ) ) {
next unless $_;
my ($file) = $_ =~ /^(.*)$/;
$log->audit( "deleting file $file" );
if ( -f $file ) {
unlink $file or
$self->file_delete( $file, %args );
}
elsif ( -d $file ) {
rmtree $file or return $log->error( "couldn't delete $file", %args);
}
else {
$log->audit( "Cannot delete unknown entity: $file" );
}
}
chdir $before;
return 1;
}
sub cwd_source_dir {
my $self = shift;
my $dir = shift or die "missing dir in request\n";
my %p = validate( @_,
{ 'src' => { type => SCALAR, optional => 1, },
'sudo' => { type => BOOLEAN, optional => 1, },
%std_opts,
}
);
my ( $src, $sudo, ) = ( $p{src}, $p{sudo}, );
my %args = $self->get_std_args( %p );
return $log->error( "Something (other than a directory) is at $dir and " .
"that's my build directory. Please remove it and try again!", %args )
if ( -e $dir && !-d $dir );
if ( !-d $dir ) {
_try_mkdir( $dir ); # use the perl builtin mkdir
if ( !-d $dir ) {
$log->audit( "trying again with system mkdir...");
$self->mkdir_system( dir => $dir, %args);
if ( !-d $dir ) {
$log->audit( "trying one last time with $sudo mkdir -p....");
$self->mkdir_system( dir => $dir, sudo => 1, %args)
or return $log->error("Couldn't create $dir.", %args);
}
}
}
chdir $dir or return $log->error( "failed to cd to $dir: $!", %args);
return 1;
}
sub dump_audit {
my $self = shift;
my %p = validate( @_, { %std_opts } );
my $audit = $log->{audit} or return;
return if ! $log->{last_audit};
return if $log->{last_audit} == scalar @$audit; # nothing new
if ( $p{quiet} ) { # hide/mask unreported messages
$log->{last_audit} = scalar @$audit;
$log->{last_error} = scalar @{ $log->{errors}};
return 1;
};
print "\n\t\t\tAudit History Report \n\n";
for( my $i = $log->{last_audit}; $i < scalar @$audit; $i++ ) {
print " $audit->[$i]\n";
$log->{last_audit}++;
};
return 1;
};
sub dump_errors {
my $self = shift;
my $last_line = $log->{last_error} or return;
return if $last_line == scalar @{ $log->{errors} }; # everything dumped
print "\n\t\t\t Error History Report \n\n";
my $i = 0;
foreach ( @{ $log->{errors} } ) {
$i++;
next if $i < $last_line;
my $msg = $_->{errmsg};
my $loc = " at $_->{errloc}";
print $msg;
for (my $j=length($msg); $j < 90-length($loc); $j++) { print '.'; };
print " $loc\n";
};
print "\n";
$log->{last_error} = $i;
return;
};
sub _try_mkdir {
my ( $dir ) = @_;
mkpath( $dir, 0, oct('0755') )
or return $log->error( "mkdir $dir failed: $!");
$log->audit( "created $dir");
return 1;
}
sub error {
my $self = shift;
my $message = shift;
my %p = validate( @_,
{ location => { type => SCALAR, optional => 1, },
%std_opts,
},
);
my $location = $p{location};
my $debug = $p{debug};
my $fatal = $p{fatal};
if ( $message ) {
my @caller = $p{caller} || caller;
# append message and location to the error stack
push @{ $log->{errors} }, {
errmsg => $message,
errloc => $location || join( ", ", $caller[0], $caller[2] ),
};
}
else {
$message = @{ $log->{errors} }[-1];
}
if ( $debug || $fatal ) {
$self->dump_audit();
$self->dump_errors();
}
exit 1 if $fatal;
return;
}
sub extract_archive {
my $self = shift;
my $archive = shift or die "missing archive name";
my %p = validate( @_, { %std_opts } );
my %args = $self->get_std_args( %p );
my $r;
if ( !-e $archive ) {
if ( -e "$archive.tar.gz" ) { $archive = "$archive.tar.gz" }
elsif ( -e "$archive.tgz" ) { $archive = "$archive.tgz" }
elsif ( -e "$archive.tar.bz2" ) { $archive = "$archive.tar.bz2" }
else {
return $log->error( "file $archive is missing!", %args );
}
}
$log->audit("found $archive");
$ENV{PATH} = '/bin:/usr/bin'; # do this or taint checks will blow up on ``
return $log->error( "unknown archive type: $archive", %args )
if $archive !~ /[bz2|gz]$/;
# find these binaries, we need them to inspect and expand the archive
my $tar = $self->find_bin( 'tar', %args );
my $file = $self->find_bin( 'file', %args );
my %types = (
gzip => { bin => 'gunzip', content => 'gzip', },
bzip => { bin => 'bunzip2', content => 'b(un)?zip2', },
# on BSD bunzip2, on Linux bzip2
);
my $type
= $archive =~ /bz2$/ ? 'bzip'
: $archive =~ /gz$/ ? 'gzip'
: return $log->error( 'unknown archive type', %args);
# make sure the archive contents match the file extension
return $log->error( "$archive not a $type compressed file", %args)
unless grep ( /$types{$type}{content}/, `$file $archive` );
my $bin = $self->find_bin( $types{$type}{bin}, %args);
$self->syscmd( "$bin -c $archive | $tar -xf -" ) or return;
$log->audit( "extracted $archive" );
return 1;
}
sub file_delete {
my $self = shift;
my $file = shift or die "missing file argument";
my %p = validate( @_,
{ 'sudo' => { type => BOOLEAN, optional => 1, default => 0 },
%std_opts,
}
);
my %args = $self->get_std_args( %p );
return $log->error( "$file does not exist", %args ) if !-e $file;
if ( -w $file ) {
$log->audit( "write permission to $file: ok" );
unlink $file or return $log->error( "failed to delete $file", %args );
$log->audit( "deleted: $file" );
return 1;
}
if ( !$p{sudo} ) { # all done
return -e $file ? undef : 1;
}
my $err = "trying with system rm";
my $rm_command = $self->find_bin( "rm", %args );
$rm_command .= " -f $file";
if ( $< != 0 ) { # we're not running as root
my $sudo = $self->sudo( %args );
$rm_command = "$sudo $rm_command";
$err .= " (sudo)";
}
$self->syscmd( $rm_command, %args )
or return $log->error( $err, %args );
return -e $file ? 0 : 1;
}
sub file_is_newer {
my $self = shift;
my %p = validate( @_,
{ f1 => { type => SCALAR },
f2 => { type => SCALAR },
%std_opts,
}
);
my ( $file1, $file2 ) = ( $p{f1}, $p{f2} );
# get file attributes via stat
# (dev,ino,mode,nlink,uid,gid,rdev,size,atime,mtime,ctime,blksize,blocks)
$log->audit( "checking age of $file1 and $file2" );
my $stat1 = stat($file1)->mtime;
my $stat2 = stat($file2)->mtime;
$log->audit( "timestamps are $stat1 and $stat2");
return 1 if ( $stat2 > $stat1 );
return;
# I could just:
#
# if ( stat($f1)[9] > stat($f2)[9] )
#
# but that forces the reader to read the man page for stat
# to see what's happening
}
sub file_read {
my $self = shift;
my $file = shift or return $log->error("missing filename in request");
my %p = validate(
@_,
{ 'max_lines' => { type => SCALAR, optional => 1 },
'max_length' => { type => SCALAR, optional => 1 },
%std_opts
}
);
my ( $max_lines, $max_length ) = ( $p{max_lines}, $p{max_length} );
my %args = $self->get_std_args( %p );
return $log->error( "$file does not exist!", %args) if !-e $file;
return $log->error( "$file is not readable", %args ) if !-r $file;
open my $FILE, '<', $file or
return $log->error( "could not open $file: $OS_ERROR", %args );
my ( $line, @lines );
if ( ! $max_lines) {
chomp( @lines = <$FILE> );
close $FILE;
return @lines;
# TODO: make max_length work with slurp mode, without doing something ugly like
# reading in the entire line and then truncating it.
};
my $i = 0;
while ( $i < $max_lines ) {
if ($max_length) { $line = substr <$FILE>, 0, $max_length; }
else { $line = <$FILE>; };
last if ! $line;
last if eof $FILE;
push @lines, $line;
$i++;
}
chomp @lines;
close $FILE;
return @lines;
}
sub file_mode {
my $self = shift;
my %p = validate( @_,
{ 'file' => { type => SCALAR },
%std_opts
}
);
my $file = $p{file};
my %args = $self->get_std_args( %p );
return $log->error( "file '$file' does not exist!", %args)
if !-e $file;
# one way to get file mode (using File::mode)
# my $raw_mode = stat($file)->[2];
## no critic
my $mode = sprintf "%04o", stat($file)->[2] & 07777;
# another way to get it
# my $st = stat($file);
# my $mode = sprintf "%lo", $st->mode & 07777;
$log->audit( "file $file has mode: $mode" );
return $mode;
}
sub file_write {
my $self = shift;
my $file = shift or return $log->error("missing filename in request");
my %p = validate(
@_,
{ 'lines' => { type => ARRAYREF },
'append' => { type => BOOLEAN, optional => 1, default => 0 },
'mode' => { type => SCALAR, optional => 1 },
%std_opts
}
);
my $append = $p{append};
my $lines = $p{lines};
my %args = $self->get_std_args( %p );
return $log->error( "oops, $file is a directory", %args) if -d $file;
return $log->error( "oops, $file is not writable", %args )
if ( ! $self->is_writable( $file, %args) );
my $m = "wrote";
my $write_mode = '>'; # (over)write
if ( $append ) {
$m = "appended";
$write_mode = '>>';
if ( -f $file ) {
copy $file, "$file.tmp" or return $log->error(
"couldn't create $file.tmp for safe append", %args );
};
};
open my $HANDLE, $write_mode, "$file.tmp"
or return $log->error( "file_write: couldn't open $file: $!", %args );
my $c = 0;
foreach ( @$lines ) { chomp; print $HANDLE "$_\n"; $c++ };
close $HANDLE or return $log->error( "couldn't close $file: $!", %args );
$log->audit( "file_write: $m $c lines to $file", %args );
move( "$file.tmp", $file )
or return $log->error(" unable to update $file", %args);
# set file permissions mode if requested
$self->chmod( file => $file, mode => $p{mode}, %args )
or return if $p{mode};
return 1;
}
sub files_diff {
my $self = shift;
my %p = validate(
@_,
{ f1 => { type => SCALAR },
f2 => { type => SCALAR },
type => { type => SCALAR, optional => 1, default => 'text' },
%std_opts,
}
);
my ( $f1, $f2, $type ) = ( $p{f1}, $p{f2}, $p{type} );
my %args = $log->get_std_args(%p);
if ( !-e $f1 || !-e $f2 ) {
$log->error( "$f1 or $f2 does not exist!", %args );
return -1;
};
return $self->files_diff_md5( $f1, $f2, \%args)
if $type ne "text";
### TODO
# use file here to make sure files are ASCII
#
$log->audit("comparing ascii files $f1 and $f2 using diff", %args);
my $diff = $self->find_bin( 'diff', %args );
my $r = `$diff $f1 $f2`;
chomp $r;
return $r;
};
sub files_diff_md5 {
my $self = shift;
my ($f1, $f2, $args) = @_;
$log->audit("comparing $f1 and $f2 using md5", %$args);
eval { require Digest::MD5 };
return $log->error( "couldn't load Digest::MD5!", %$args )
if $EVAL_ERROR;
$log->audit( "\t Digest::MD5 loaded", %$args );
my @md5sums;
foreach my $f ( $f1, $f2 ) {
my ( $sum, $changed );
# if the md5 file exists
if ( -f "$f.md5" ) {
$sum = $self->file_read( "$f.md5", %$args );
$log->audit( " md5 file for $f exists", %$args );
}
# if the md5 file is missing, invalid, or older than the file, recompute it
if ( ! -f "$f.md5" or $sum !~ /[0-9a-f]+/i or
$self->file_is_newer( f1 => "$f.md5", f2 => $f, %$args )
)
{
my $ctx = Digest::MD5->new;
open my $FILE, '<', $f;
$ctx->addfile(*$FILE);
$sum = $ctx->hexdigest;
close $FILE;
$changed++;
$log->audit(" calculated md5: $sum", %$args);
}
push( @md5sums, $sum );
$self->file_write( "$f.md5", lines => [$sum], %$args ) if $changed;
}
return if $md5sums[0] eq $md5sums[1];
return 1;
}
sub find_bin {
my $self = shift;
my $bin = shift or die "missing argument to find_bin\n";
my %p = validate( @_,
{ 'dir' => { type => SCALAR, optional => 1, },
%std_opts,
},
);
my $prefix = "/usr/local";
my %args = $log->get_std_args(%p);
if ( $bin =~ /^\// && -x $bin ) { # we got a full path
$log->audit( "find_bin: found $bin", %args );
return $bin;
};
my @prefixes;
push @prefixes, $p{dir} if $p{dir};
push @prefixes, qw"
/usr/local/bin /usr/local/sbin/ /opt/local/bin /opt/local/sbin
$prefix/mysql/bin /bin /usr/bin /sbin /usr/sbin
";
push @prefixes, cwd;
my $found;
foreach my $prefix ( @prefixes ) {
if ( -x "$prefix/$bin" ) {
$found = "$prefix/$bin" and last;
};
};
if ($found) {
$log->audit( "find_bin: found $found", %args);
return $found;
}
return $log->error( "find_bin: could not find $bin", %args);
}
sub find_config {
my $self = shift;
my $file = shift or die "missing file name";
my %p = validate( @_,
{ etcdir => { type => SCALAR | UNDEF, optional => 1, },
%std_opts,
}
);
#my @caller = caller;
#warn sprintf( "find_config loaded by %s, %s, %s\n", @caller );
$log->audit("find_config: searching for $file");
my @etc_dirs;
my $etcdir = $p{etcdir};
push @etc_dirs, $etcdir if ( $etcdir && -d $etcdir );
push @etc_dirs, qw{ /opt/local/etc /usr/local/etc /etc etc };
push @etc_dirs, cwd;
my $r = $self->find_readable( $file, @etc_dirs );
if ( $r ) {
$log->audit( " found $r" );
return $r;
};
# try $file-dist in the working dir
if ( -r "./$file-dist" ) {
$log->audit(" found in ./");
return cwd . "/$file-dist";
}
return $log->error( "could not find $file", fatal => $p{fatal} );
}
sub find_readable {
my $self = shift;
my $file = shift;
my $dir = shift or return; # break recursion at end of @_
#$log->audit("looking for $file in $dir") if $self->{debug};
if ( -r "$dir/$file" ) {
no warnings;
return "$dir/$file"; # success
}
if ( ! -d $dir ) {
return $self->find_readable( $file, @_ );
};
# warn about directories we don't have read access to
if ( ! -r $dir ) {
$log->error( "$dir is not readable", fatal => 0 );
return $self->find_readable( $file, @_ );
};
# warn about files that exist but aren't readable
if ( -e "$dir/$file" ) {
$log->error( "$dir/$file is not readable", fatal => 0);
};
return $self->find_readable( $file, @_ );
}
sub fstab_list {
my $self = shift;
my %p = validate( @_, { %std_opts, } );
if ( $OSNAME eq "darwin" ) {
return ['fstab not used on Darwin!'];
}
my $fstab = "/etc/fstab";
if ( !-e $fstab ) {
print "fstab_list: FAILURE: $fstab does not exist!\n" if $p{debug};
return;
}
my $grep = $self->find_bin( "grep", debug => 0 );
my @fstabs = `$grep -v cdr $fstab`;
# foreach my $fstab (@fstabs)
# {}
# my @fields = split(/ /, $fstab);
# #print "device: $fields[0] mount: $fields[1]\n";
# {};
# print "\n\n END of fstabs\n\n";
return \@fstabs;
}
sub get_cpan_config {
my $ftp = `which ftp`; chomp $ftp;
my $gzip = `which gzip`; chomp $gzip;
my $unzip = `which unzip`; chomp $unzip;
my $tar = `which tar`; chomp $tar;
my $make = `which make`; chomp $make;
my $wget = `which wget`; chomp $wget;
return
{
'build_cache' => q[10],
'build_dir' => qq[$ENV{HOME}/.cpan/build],
'cache_metadata' => q[1],
'cpan_home' => qq[$ENV{HOME}/.cpan],
'ftp' => $ftp,
'ftp_proxy' => q[],
'getcwd' => q[cwd],
'gpg' => q[],
'gzip' => $gzip,
'histfile' => qq[$ENV{HOME}/.cpan/histfile],
'histsize' => q[100],
'http_proxy' => q[],
'inactivity_timeout' => q[5],
'index_expire' => q[1],
'inhibit_startup_message' => q[1],
'keep_source_where' => qq[$ENV{HOME}/.cpan/sources],
'lynx' => q[],
'make' => $make,
'make_arg' => q[],
'make_install_arg' => q[],
'makepl_arg' => q[],
'ncftp' => q[],
'ncftpget' => q[],
'no_proxy' => q[],
'pager' => q[less],
'prerequisites_policy' => q[follow],
'scan_cache' => q[atstart],
'shell' => q[/bin/csh],
'tar' => $tar,
'term_is_latin' => q[1],
'unzip' => $unzip,
'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/' ],
'wget' => $wget,
};
}
sub get_dir_files {
my $self = shift;
my $dir = shift or die "missing dir name";
my %p = validate( @_, { %std_opts } );
my %args = $self->get_std_args( %p );
my @files;
return $log->error( "dir $dir is not a directory!", %args)
if ! -d $dir;
opendir D, $dir or return $log->error( "couldn't open $dir: $!", %args );
while ( defined( my $f = readdir(D) ) ) {
next if $f =~ /^\.\.?$/;
push @files, "$dir/$f";
}
closedir(D);
return @files;
}
sub get_my_ips {
############################################
# Usage : @list_of_ips_ref = $util->get_my_ips();
# Purpose : get a list of IP addresses on local interfaces
# Returns : an arrayref of IP addresses
# Parameters : only - can be one of: first, last
# : exclude_locahost (all 127.0 addresses)
# : exclude_internals (192.168, 10., 169., 172.)
# : exclude_ipv6
# Comments : exclude options are boolean and enabled by default.
# tested on Mac OS X and FreeBSD
my $self = shift;
my %p = validate(
@_,
{ 'only' => { type => SCALAR, optional => 1, default => 0 },
'exclude_localhost' =>
{ type => BOOLEAN, optional => 1, default => 1 },
'exclude_internals' =>
{ type => BOOLEAN, optional => 1, default => 1 },
'exclude_ipv6' =>
{ type => BOOLEAN, optional => 1, default => 1 },
%std_opts,
}
);
my $debug = $p{debug};
my $only = $p{only};
my $ifconfig = $self->find_bin( "ifconfig", debug => 0 );
my $once = 0;
TRY:
my @ips = grep {/inet/} `$ifconfig`; chomp @ips;
@ips = grep {!/inet6/} @ips if $p{exclude_ipv6};
@ips = grep {!/inet 127\.0\.0/} @ips if $p{exclude_localhost};
@ips = grep {!/inet (192\.168\.|10\.|172\.16\.|169\.254\.)/} @ips
if $p{exclude_internals};
# this keeps us from failing if the box has only internal IPs
if ( @ips < 1 || $ips[0] eq "" ) {
carp "yikes, you really don't have any public IPs?!" if $debug;
$p{exclude_internals} = 0;
$once++;
goto TRY if ( $once < 2 );
}
foreach ( @ips ) { ($_) = $_ =~ m/inet ([\d\.]+)\s/; };
return [ $ips[0] ] if $only eq 'first';
return [ $ips[-1] ] if $only eq 'last';
return \@ips;
}
sub get_std_args {
my $self = shift;
my %p = @_;
my %args;
foreach ( qw/ debug fatal test_ok quiet / ) {
next if ! defined $p{$_};
$args{$_} = $p{$_};
};
return %args;
};
sub get_the_date {
my $self = shift;
my %p = validate(
@_,
{ 'bump' => { type => SCALAR, optional => 1, },
%std_opts
}
);
my $bump = $p{bump} || 0;
my %args = $self->get_std_args( %p );
my $time = time;
my $mess = "get_the_date time: " . time;
$bump = $bump * 86400 if $bump;
my $offset_time = time - $bump;
$mess .= ", (selected $offset_time)" if $time != $offset_time;
# load Date::Format to get the time2str function
eval { require Date::Format };
if ( !$EVAL_ERROR ) {
my $ss = Date::Format::time2str( "%S", ($offset_time) );
my $mn = Date::Format::time2str( "%M", ($offset_time) );
my $hh = Date::Format::time2str( "%H", ($offset_time) );
my $dd = Date::Format::time2str( "%d", ($offset_time) );
my $mm = Date::Format::time2str( "%m", ($offset_time) );
my $yy = Date::Format::time2str( "%Y", ($offset_time) );
my $lm = Date::Format::time2str( "%m", ( $offset_time - 2592000 ) );
$log->audit( "$mess, $yy/$mm/$dd $hh:$mn", %args);
return $dd, $mm, $yy, $lm, $hh, $mn, $ss;
}
# 0 1 2 3 4 5 6 7 8
# ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
# localtime(time);
# 4 = month + 1 ( see perldoc localtime)
# 5 = year + 1900 ""
my @fields = localtime($offset_time);
my $ss = sprintf( "%02i", $fields[0] ); # seconds
my $mn = sprintf( "%02i", $fields[1] ); # minutes
my $hh = sprintf( "%02i", $fields[2] ); # hours (24 hour clock)
my $dd = sprintf( "%02i", $fields[3] ); # day of month
my $mm = sprintf( "%02i", $fields[4] + 1 ); # month
my $yy = ( $fields[5] + 1900 ); # year
$log->audit( "$mess, $yy/$mm/$dd $hh:$mn", %args );
return $dd, $mm, $yy, undef, $hh, $mn, $ss;
}
sub get_mounted_drives {
my $self = shift;
my %p = validate( @_, { %std_opts } );
my %args = $log->get_std_args( %p );
my $mount = $self->find_bin( 'mount', %args );
-x $mount or return $log->error( "I couldn't find mount!", %args );
$ENV{PATH} = "";
my %hash;
foreach (`$mount`) {
my ( $d, $m ) = $_ =~ /^(.*) on (.*) \(/;
#if ( $m =~ /^\// && $d =~ /^\// ) # mount drives that begin with /
if ( $m && $m =~ /^\// ) { # only mounts that begin with /
$log->audit( "adding: $m \t $d" ) if $p{debug};
$hash{$m} = $d;
}
}
return \%hash;
}
sub get_url {
my $self = shift;
my $url = shift;
my %p = validate(
@_,
{ dir => { type => SCALAR, optional => 1 },
timeout => { type => SCALAR, optional => 1 },
%std_opts,
}
);
my $dir = $p{dir};
my %args = $log->get_std_args( %p );
my ($ua, $response);
## no critic ( ProhibitStringyEval )
eval "require LWP::Simple";
## use critic
return $self->get_url_system( $url, %p ) if $EVAL_ERROR;
my $uri = URI->new($url);
my @parts = $uri->path_segments;
my $file = $parts[-1]; # everything after the last / in the URL
my $file_path = $file;
$file_path = "$dir/$file" if $dir;
$log->audit( "fetching $url" );
eval { $response = LWP::Simple::mirror($url, $file_path ); };
if ( $response ) {
if ( $response == 404 ) {
return $log->error( "file not found ($url)", %args );
}
elsif ($response == 304 ) {
$log->audit( "result 304: file is up-to-date" );
}
elsif ( $response == 200 ) {
$log->audit( "result 200: file download ok" );
}
else {
$log->error( "unhandled response: $response", fatal => 0 );
};
};
return if ! -e $file_path;
return $response;
}
sub get_url_system {
my $self = shift;
my $url = shift;
my %p = validate(
@_,
{ dir => { type => SCALAR, optional => 1 },
timeout => { type => SCALAR, optional => 1, },
%std_opts,
}
);
my $dir = $p{dir};
my $debug = $p{debug};
my %args = $log->get_std_args( %p );
my ($fetchbin, $found);
if ( $OSNAME eq "freebsd" ) {
$fetchbin = $self->find_bin( 'fetch', %args);
if ( $fetchbin && -x $fetchbin ) {
$found = $fetchbin;
$found .= " -q" if !$debug;
}
}
elsif ( $OSNAME eq "darwin" ) {
$fetchbin = $self->find_bin( 'curl', %args );
if ( $fetchbin && -x $fetchbin ) {
$found = "$fetchbin -O";
$found .= " -s " if !$debug;
}
}
if ( !$found ) {
$fetchbin = $self->find_bin( 'wget', %args);
$found = $fetchbin if $fetchbin && -x $fetchbin;
}
return $log->error( "Failed to fetch $url.\n\tCouldn't find wget. Please install it.", %args )
if !$found;
my $fetchcmd = "$found $url";
my $timeout = $p{timeout} || 0;
if ( ! $timeout ) {
$self->syscmd( $fetchcmd, %args ) or return;
my $uri = URI->new($url);
my @parts = $uri->path_segments;
my $file = $parts[-1]; # everything after the last / in the URL
if ( -e $file && $dir && -d $dir ) {
$log->audit("moving file $file to $dir" );
move $file, "$dir/$file";
return 1;
};
};
my $r;
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm $timeout;
$r = $self->syscmd( $fetchcmd, %args );
alarm 0;
};
if ($EVAL_ERROR) { # propagate unexpected errors
print "timed out!\n" if $EVAL_ERROR eq "alarm\n";
return $log->error( $EVAL_ERROR, %args );
}
return $log->error( "error executing $fetchcmd", %args) if !$r;
return 1;
}
sub has_module {
my $self = shift;
my ($name, $ver) = @_;
## no critic ( ProhibitStringyEval )
eval "use $name" . ($ver ? " $ver;" : ";");
## use critic
!$EVAL_ERROR;
};
sub install_if_changed {
my $self = shift;
my %p = validate(
@_,
{ newfile => { type => SCALAR, optional => 0, },
existing=> { type => SCALAR, optional => 0, },
mode => { type => SCALAR, optional => 1, },
uid => { type => SCALAR, optional => 1, },
gid => { type => SCALAR, optional => 1, },
sudo => { type => BOOLEAN, optional => 1, default => 0 },
notify => { type => BOOLEAN, optional => 1, },
email => { type => SCALAR, optional => 1, default => 'postmaster' },
clean => { type => BOOLEAN, optional => 1, default => 1 },
archive => { type => BOOLEAN, optional => 1, default => 0 },
%std_opts,
},
);
my ( $newfile, $existing, $mode, $uid, $gid, $email) = (
$p{newfile}, $p{existing}, $p{mode}, $p{uid}, $p{gid}, $p{email} );
my ($sudo, $notify ) = ($p{sudo}, $p{notify} );
my %args = $self->get_std_args( %p );
if ( $newfile !~ /\// ) {
# relative filename given
$log->audit( "relative filename given, use complete paths "
. "for more predicatable results!\n"
. "working directory is " . cwd() );
}
return $log->error( "file ($newfile) does not exist", %args )
if !-e $newfile;
return $log->error( "file ($newfile) is not a file", %args )
if !-f $newfile;
# make sure existing and new are writable
if ( !$self->is_writable( $existing, fatal => 0 )
|| !$self->is_writable( $newfile, fatal => 0 ) ) {
# root does not have permission, sudo won't do any good
return $log->error("no write permission", %args) if $UID == 0;
if ( $sudo ) {
$sudo = $self->find_bin( 'sudo', %args ) or
return $log->error( "you are not root, sudo was not found, and you don't have permission to write to $newfile or $existing" );
}
}
my $diffie;
if ( -f $existing ) {
$diffie = $self->files_diff( %args,
f1 => $newfile,
f2 => $existing,
type => "text",
) or do {
$log->audit( "$existing is already up-to-date.", %args);
unlink $newfile if $p{clean};
return 2;
};
};
$log->audit("checking $existing", %args);
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
# install the new file
if ($sudo) {
my $cp = $self->find_bin( 'cp', %$args );
# back up the existing file
$self->syscmd( "$sudo $cp $existing $existing.bak", %$args)
if -e $existing;
# install the new one
if ( $clean ) {
my $mv = $self->find_bin( 'mv' );
$self->syscmd( "$sudo $mv $newfile $existing", %$args);
}
else {
$self->syscmd( "$sudo $cp $newfile $existing",%$args);
}
}
else {
# back up the existing file
copy( $existing, "$existing.bak" ) if -e $existing;
if ( $clean ) {
move( $newfile, $existing ) or
return $log->error( "failed copy $newfile to $existing", %$args);
}
else {
copy( $newfile, $existing ) or
return $log->error( "failed copy $newfile to $existing", %$args );
}
}
};
sub install_if_changed_notify {
my ($self, $notify, $email, $existing, $diffie) = @_;
return if ! $notify;
return if ! -f $existing;
# email diffs to admin
eval { require Mail::Send; };
return $log->error( "could not send notice, Mail::Send is not installed!", fatal => 0)
if $EVAL_ERROR;
my $msg = Mail::Send->new;
$msg->subject("$existing updated by $0");
$msg->to($email);
my $email_message = $msg->open;
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";
$email_message->close;
};
sub install_from_source {
my $self = shift;
my %p = validate(
@_,
{ 'site' => { type => SCALAR, optional => 0, },
'url' => { type => SCALAR, optional => 0, },
'package' => { type => SCALAR, optional => 0, },
'targets' => { type => ARRAYREF, optional => 1, },
'patches' => { type => ARRAYREF, optional => 1, },
'patch_url' => { type => SCALAR, optional => 1, },
'patch_args' => { type => SCALAR, optional => 1, },
'source_dir' => { type => SCALAR, optional => 1, },
'source_sub_dir' => { type => SCALAR, optional => 1, },
'bintest' => { type => SCALAR, optional => 1, },
%std_opts,
},
);
return $p{test_ok} if defined $p{test_ok};
my %args = $self->get_std_args( %p );
my ( $site, $url, $package, $targets, $patches, $bintest ) =
( $p{site}, $p{url}, $p{package},
$p{targets}, $p{patches}, $p{bintest} );
my $patch_args = $p{patch_args} || '';
my $src = $p{source_dir} || "/usr/local/src";
$src .= "/$p{source_sub_dir}" if $p{source_sub_dir};
my $original_directory = cwd;
$self->cwd_source_dir( $src, %args );
if ( $bintest && $self->find_bin( $bintest, fatal => 0, debug => 0 ) ) {
return if ! $self->yes_or_no(
"$bintest exists, suggesting that "
. "$package is installed. Do you want to reinstall?",
timeout => 60,
);
}
$log->audit( "install_from_source: building $package in $src");
$self->install_from_source_cleanup($package,$src) or return;
$self->install_from_source_get_files($package,$site,$url,$p{patch_url},$patches) or return;
$self->extract_archive( $package )
or return $log->error( "Couldn't expand $package: $!", %args );
# cd into the package directory
my $sub_path;
if ( -d $package ) {
chdir $package or
return $log->error( "FAILED to chdir $package!", %args );
}
else {
# some packages (like daemontools) unpack within an enclosing directory
$sub_path = `find ./ -name $package`; # tainted data
chomp $sub_path;
($sub_path) = $sub_path =~ /^([-\w\/.]+)$/; # untaint it
$log->audit( "found sources in $sub_path" ) if $sub_path;
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
sub install_module_cpan {
my $self = shift;
my ($module, $version) = @_;
print " from CPAN...";
require CPAN;
# some Linux distros break CPAN by auto/preconfiguring it with no URL mirrors.
# this works around that annoying little habit
no warnings;
$CPAN::Config = get_cpan_config();
use warnings;
if ( $module eq 'Provision::Unix' && $version ) {
$module =~ s/\:\:/\-/g;
$module = "M/MS/MSIMERSON/$module-$version.tar.gz";
}
CPAN::Shell->install($module);
}
sub install_module_darwin {
my $self = shift;
my $module = shift;
my $dport = '/opt/local/bin/port';
return $log->error( "Darwin ports is not installed!", fatal => 0)
if ! -x $dport;
my $port = "p5-$module";
$port =~ s/::/-/g;
system "sudo $dport install $port" or return 1;
return;
};
sub install_module_freebsd {
my $self = shift;
my ($module, $info) = @_;
my $portname = $info->{port}; # optional override
if ( ! $portname ) {
$portname = "p5-$module";
$portname =~ s/::/-/g;
};
my $r = `/usr/sbin/pkg_info | /usr/bin/grep $portname`;
return $log->audit( "$module is installed as $r") if $r;
my $portdir = glob("/usr/ports/*/$portname");
if ( $portdir && -d $portdir && chdir $portdir ) {
$log->audit( "installing $module from ports ($portdir)" );
system "make clean && make install clean";
return 1;
}
return;
}
sub install_module_from_src {
my $self = shift;
my %p = validate( @_, {
module => { type=>SCALAR, optional=>0, },
archive => { type=>SCALAR, optional=>0, },
site => { type=>SCALAR, optional=>0, },
url => { type=>SCALAR, optional=>0, },
src => { type=>SCALAR, optional=>1, default=>'/usr/local/src' },
targets => { type=>ARRAYREF,optional=>1, },
%std_opts,
},
);
my ( $module, $site, $url, $src, $targets )
= ( $p{module}, $p{site}, $p{url}, $p{src}, $p{targets} );
my %args = $self->get_std_args( %p );
$self->cwd_source_dir( $src, %args );
$log->audit( "checking for previous build attempts.");
if ( -d $module ) {
if ( ! $self->source_warning( package=>$module, src=>$src, %args ) ) {
print "\nokay, skipping install.\n";
return;
}
$self->syscmd( cmd => "rm -rf $module", %args );
}
$self->sources_get(
site => $site,
path => $url,
package => $p{'archive'} || $module,
%args,
) or return;
$self->extract_archive( $module ) or return;
my $found;
print "looking for $module in $src...";
foreach my $file ( $self->get_dir_files( $src ) ) {
next if ! -d $file; # only check directories
next if $file !~ /$module/;
print "found: $file\n";
$found++;
chdir $file;
unless ( @$targets[0] && @$targets[0] ne "" ) {
$log->audit( "using default targets." );
$targets = [ "perl Makefile.PL", "make", "make install" ];
}
print "building with targets " . join( ", ", @$targets ) . "\n";
foreach (@$targets) {
return $log->error( "$_ failed!", %args)
if ! $self->syscmd( cmd => $_ , %args);
}
chdir('..');
$self->syscmd( cmd => "rm -rf $file", debug=>0);
last;
}
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
sub install_module_linux {
my $self = shift;
my ($module, $info ) = @_;
my $rpm = $info->{rpm};
if ( $rpm ) {
my $portname = "perl-$rpm";
$portname =~ s/::/-/g;
my $yum = '/usr/bin/yum';
system "$yum -y install $portname" if -x $yum;
}
};
sub is_interactive {
## no critic
# borrowed from IO::Interactive
my $self = shift;
my ($out_handle) = ( @_, select ); # Default to default output handle
# Not interactive if output is not to terminal...
return if not -t $out_handle;
# If *ARGV is opened, we're interactive if...
if ( openhandle * ARGV ) {
# ...it's currently opened to the magic '-' file
return -t *STDIN if defined $ARGV && $ARGV eq '-';
# ...it's at end-of-file and the next file is the magic '-' file
return @ARGV > 0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;
# ...it's directly attached to the terminal
return -t *ARGV;
};
# If *ARGV isn't opened, it will be interactive if *STDIN is attached
# to a terminal and either there are no files specified on the command line
# or if there are files and the first is the magic '-' file
return -t *STDIN && ( @ARGV == 0 || $ARGV[0] eq '-' );
}
sub is_process_running {
my ( $self, $process ) = @_;
my $ps = $self->find_bin( 'ps', debug => 0 );
if ( lc($OSNAME) =~ /solaris/i ) { $ps .= ' -ef'; }
elsif ( lc($OSNAME) =~ /irix/i ) { $ps .= ' -ef'; }
elsif ( lc($OSNAME) =~ /linux/i ) { $ps .= ' -efw'; }
else { $ps .= ' axww'; };
my @procs = `$ps`;
chomp @procs;
return scalar grep {/$process/i} @procs;
}
sub is_readable {
my $self = shift;
my $file = shift or die "missing file or dir name\n";
my %p = validate( @_, { %std_opts } );
my %args = ( debug => $p{debug}, fatal => $p{fatal} );
-e $file or return $log->error( "$file does not exist.", %args);
-r $file or return $log->error( "$file is not readable by you ("
. getpwuid($>)
. "). You need to fix this, using chown or chmod.", %args);
return 1;
}
sub is_writable {
my $self = shift;
my $file = shift or die "missing file or dir name\n";
my %p = validate( @_, { %std_opts } );
my %args = $self->get_std_args( %p );
my $nl = "\n";
$nl = "<br>" if ( $ENV{GATEWAY_INTERFACE} );
if ( !-e $file ) {
my ( $base, $path, $suffix ) = fileparse($file);
return $log->error( "is_writable: $path not writable by "
. getpwuid($>)
. "$nl$nl", %args) if (-e $path && !-w $path);
return 1;
}
return $log->error( " $file not writable by " . getpwuid($>) . "$nl$nl", %args ) if ! -w $file;
$log->audit( "$file is writable" );
return 1;
}
sub logfile_append {
my $self = shift;
my %p = validate(
@_,
{ 'file' => { type => SCALAR, optional => 0, },
'lines' => { type => ARRAYREF, optional => 0, },
'prog' => { type => BOOLEAN, optional => 1, default => 0, },
%std_opts,
},
);
my ( $file, $lines ) = ( $p{file}, $p{lines} );
my %args = $self->get_std_args( %p );
my ( $dd, $mm, $yy, $lm, $hh, $mn, $ss ) = $self->get_the_date( %args );
open my $LOG_FILE, '>>', $file
or return $log->error( "couldn't open $file: $OS_ERROR", %args);
print $LOG_FILE "$yy-$mm-$dd $hh:$mn:$ss $p{prog} ";
my $i;
foreach (@$lines) { print $LOG_FILE "$_ "; $i++ }
print $LOG_FILE "\n";
close $LOG_FILE;
$log->audit( "logfile_append wrote $i lines to $file", %args );
return 1;
}
sub mail_toaster {
my $self = shift;
$self->install_module( 'Mail::Toaster' );
}
sub mkdir_system {
my $self = shift;
my %p = validate(
@_,
{ 'dir' => { type => SCALAR, optional => 0, },
'mode' => { type => SCALAR, optional => 1, },
'sudo' => { type => BOOLEAN, optional => 1, default => 0 },
%std_opts,
}
);
my ( $dir, $mode ) = ( $p{dir}, $p{mode} );
my %args = $self->get_std_args( %p );
return $log->audit( "mkdir_system: $dir already exists.") if -d $dir;
my $mkdir = $self->find_bin( 'mkdir', %args) or return;
# if we are root, just do it (no sudo nonsense)
if ( $< == 0 ) {
$self->syscmd( "$mkdir -p $dir", %args) or return;
$self->chmod( dir => $dir, mode => $mode, %args ) if $mode;
return 1 if -d $dir;
return $log->error( "failed to create $dir", %args);
}
if ( $p{sudo} ) {
my $sudo = $self->sudo();
$log->audit( "trying $sudo $mkdir -p $dir");
$self->syscmd( "$sudo $mkdir -p $dir", %args);
$log->audit( "setting ownership to $<.");
my $chown = $self->find_bin( 'chown', %args);
$self->syscmd( "$sudo $chown $< $dir", %args);
$self->chmod( dir => $dir, mode => $mode, sudo => $sudo, %args)
if $mode;
return -d $dir ? 1 : 0;
}
$log->audit( "trying mkdir -p $dir" );
# no root and no sudo, just try and see what happens
$self->syscmd( "$mkdir -p $dir", %args ) or return;
$self->chmod( dir => $dir, mode => $mode, %args) if $mode;
return $log->audit( "mkdir_system created $dir" ) if -d $dir;
return $log->error( '', %args );
}
sub path_parse {
# code left here for reference, use File::Basename instead
my ( $self, $dir ) = @_;
# if it ends with a /, chop if off
if ( $dir =~ q{/$} ) { chop $dir }
# get the position of the last / in the path
my $rindex = rindex( $dir, "/" );
# grabs everything up to the last /
my $updir = substr( $dir, 0, $rindex );
$rindex++;
# matches from the last / char +1 to the end of string
my $curdir = substr( $dir, $rindex );
return $updir, $curdir;
}
sub check_pidfile {
my $self = shift;
my $file = shift;
my %p = validate( @_, { %std_opts } );
my %args = $self->get_std_args( %p );
return $log->error( "missing filename", %args) if ! $file;
return $log->error( "$file is not a regular file", %args)
if ( -e $file && !-f $file );
# test if file & enclosing directory is writable, revert to /tmp if not
$self->is_writable( $file, %args)
or do {
my ( $base, $path, $suffix ) = fileparse($file);
$log->audit( "NOTICE: using /tmp for file, $path is not writable!", %args);
$file = "/tmp/$base";
};
# if it does not exist
if ( !-e $file ) {
$log->audit( "writing process id $PROCESS_ID to $file...");
$self->file_write( $file, lines => [$PROCESS_ID], %args) and return $file;
};
my $age = time() - stat($file)->mtime;
if ( $age < 1200 ) { # less than 20 minutes old
return $log->error( "check_pidfile: $file is " . $age / 60
. " minutes old and might still be running. If it is not running,"
. " please remove the file (rm $file).", %args);
}
elsif ( $age < 3600 ) { # 1 hour
return $log->error( "check_pidfile: $file is " . $age / 60
. " minutes old and might still be running. If it is not running,"
. " please remove the pidfile. (rm $file)", %args);
}
else {
$log->audit( "check_pidfile: $file is $age seconds old, ignoring.", %args);
}
return $file;
}
sub parse_config {
my $self = shift;
my $file = shift or die "missing file name";
my %p = validate( @_, {
etcdir => { type=>SCALAR, optional=>1, },
%std_opts,
},
);
my %args = $self->get_std_args( %p );
if ( ! -f $file ) { $file = $self->find_config( $file, %p ); };
if ( ! $file || ! -r $file ) {
return $log->error( "could not find config file!", %args);
};
my %hash;
$log->audit( " read config from $file");
my @config = $self->file_read( $file );
foreach ( @config ) {
next if ! $_;
chomp;
next if $_ =~ /^#/; # skip lines beginning with #
next if $_ =~ /^[\s+]?$/; # skip empty lines
my ( $key, $val ) = $self->parse_line( $_ );
next if ! $key;
$hash{$key} = $val;
}
return \%hash;
}
sub parse_line {
my $self = shift;
my $line = shift;
my %p = validate( @_, {
strip => { type => BOOLEAN, optional=>1, default=>1 },
},
);
my $strip = $p{strip};
# this regexp must match and return these patterns
# localhost1 = localhost, disk, da0, disk_da0
# hosts = localhost lab.simerson.net seattle.simerson.net
my ( $key, $val ) = $line =~ /\A
\s* # any amount of leading white space, greedy
(.*?) # all characters, non greedy
\s* # any amount of white space, greedy
=
\s* # same, except on the other side of the =
(.*?)
\s*
\z/xms;
# remove any comments
if ( $strip && $val && $val =~ /#/ ) {
# removes everything from a # to the right, including
# any spaces to the left of the # symbol.
($val) = $val =~ /(.*?\S)\s*#/;
}
return ( $key, $val );
}
sub provision_unix {
my $self = shift;
$self->install_module( 'Provision::Unix' );
}
sub regexp_test {
my $self = shift;
my %p = validate(
@_,
{ 'exp' => { type => SCALAR },
'string' => { type => SCALAR },
'pbp' => { type => BOOLEAN, optional => 1, default => 0 },
%std_opts,
},
);
my $debug = $p{debug};
my ( $exp, $string, $pbp ) = ( $p{exp}, $p{string}, $p{pbp} );
if ($pbp) {
if ( $string =~ m{($exp)}xms ) {
print "\t Matched pbp: |$`<$&>$'|\n" if $debug;
return $1;
}
else {
print "\t No match.\n" if $debug;
return;
}
}
if ( $string =~ m{($exp)} ) {
print "\t Matched: |$`<$&>$'|\n" if $debug;
return $1;
}
print "\t No match.\n" if $debug;
return;
}
sub sources_get {
my $self = shift;
my %p = validate(
@_,
{ 'package' => { type => SCALAR, optional => 0 },
site => { type => SCALAR, optional => 0 },
path => { type => SCALAR, optional => 1 },
%std_opts,
},
);
my ( $package, $site, $path ) = ( $p{package}, $p{site}, $p{path} );
my %args = $self->get_std_args( %p );
$log->audit( "sources_get: fetching $package from site $site\n\t path: $path");
my @extensions = qw/ tar.gz tgz tar.bz2 tbz2 /;
my $filet = $self->find_bin( 'file', %args) or return;
my $grep = $self->find_bin( 'grep', %args) or return;
foreach my $ext (@extensions) {
my $tarball = "$package.$ext";
next if !-e $tarball;
$log->audit( " found $tarball!") if -e $tarball;
if (`$filet $tarball | $grep compress`) {
$self->yes_or_no( "$tarball exists, shall I use it?: ")
and return $log->audit( " ok, using existing archive: $tarball");
}
$self->file_delete( $tarball, %args );
}
foreach my $ext (@extensions) {
my $tarball = "$package.$ext";
$log->audit( "sources_get: fetching $site$path/$tarball");
$self->get_url( "$site$path/$tarball", fatal => 0)
or return $log->error( "couldn't fetch $site$path/$tarball", %args);
next if ! -e $tarball;
$log->audit( " sources_get: testing $tarball ");
if (`$filet $tarball | $grep zip`) {
$log->audit( " sources_get: looks good!");
return 1;
};
$log->audit( " oops, is not [b|g]zipped data!");
$self->file_delete( $tarball, %args);
}
return $log->error( "unable to get $package", %args );
}
sub source_warning {
my $self = shift;
my %p = validate(
@_,
{ 'package' => { type => SCALAR, },
'clean' => { type => BOOLEAN, optional => 1, default => 1 },
'src' => {
type => SCALAR,
optional => 1,
default => "/usr/local/src"
},
'timeout' => { type => SCALAR, optional => 1, default => 60 },
%std_opts,
},
);
my ( $package, $src ) = ( $p{package}, $p{src} );
my %args = $self->get_std_args( %p );
return $log->audit( "$package sources not present.", %args ) if !-d $package;
if ( -e $package ) {
print "
$package sources are already present, indicating that you've already
installed $package. If you want to reinstall it, remove the existing
sources (rm -r $src/$package) and re-run this script\n\n";
return if !$p{clean};
}
if ( !$self->yes_or_no( "\n\tMay I remove the sources for you?", timeout => $p{timeout} ) ) {
print "\nOK then, skipping $package install.\n\n";
return;
};
$log->audit( " wd: " . cwd );
$log->audit( " deleting $src/$package");
return $log->error( "failed to delete $package: $OS_ERROR", %args )
if ! rmtree "$src/$package";
return 1;
}
sub sudo {
my $self = shift;
my %p = validate( @_, { %std_opts } );
# if we are running as root via $<
if ( $REAL_USER_ID == 0 ) {
$log->audit( "sudo: you are root, sudo isn't necessary.");
return ''; # return an empty string, purposefully
}
my $sudo;
my $path_to_sudo = $self->find_bin( 'sudo', fatal => 0 );
# sudo is installed
if ( $path_to_sudo && -x $path_to_sudo ) {
$log->audit( "sudo: sudo was found at $path_to_sudo.");
return "$path_to_sudo -p 'Password for %u@%h:'";
}
$log->audit( "\nWARNING: Couldn't find sudo. This may not be a problem but some features require root permissions and will not work without them. Having sudo can allow legitimate and limited root permission to non-root users. Some features of Apa...
# try installing sudo
$self->yes_or_no( "may I try to install sudo?", timeout => 20 ) or do {
print "very well then, skipping along.\n";
return "";
};
-x $self->find_bin( "sudo", fatal => 0 ) or
$self->install_from_source(
package => 'sudo-1.6.9p17',
site => 'http://www.courtesan.com',
url => '/sudo/',
targets => [ './configure', 'make', 'make install' ],
patches => '',
debug => 1,
);
# can we find it now?
$path_to_sudo = $self->find_bin( "sudo" );
if ( !-x $path_to_sudo ) {
print "sudo install failed!";
return '';
}
return "$path_to_sudo -p 'Password for %u@%h:'";
}
sub syscmd {
my $self = shift;
my $cmd = shift or die "missing command!\n";
my %p = validate(
@_,
{ 'timeout' => { type => SCALAR, optional => 1 },
%std_opts,
},
);
my %args = $log->get_std_args( %p );
$log->audit("syscmd: $cmd");
my ( $is_safe, $tainted, $bin, @args );
# separate the program from its arguments
if ( $cmd =~ m/\s+/xm ) {
($cmd) = $cmd =~ /^\s*(.*?)\s*$/; # trim lead/trailing whitespace
@args = split /\s+/, $cmd; # split on whitespace
$bin = shift @args;
$is_safe++;
$log->audit("\tprogram: $bin, args : " . join ' ', @args, %args);
}
else {
# does not not contain a ./ pattern
if ( $cmd !~ m{\./} ) { $bin = $cmd; $is_safe++; };
}
if ( $is_safe && !$bin ) {
return $log->error("command is not safe! BAILING OUT!", %args);
}
my $message;
$message .= "syscmd: bin is <$bin>" if $bin;
$message .= " (safe)" if $is_safe;
$log->audit($message, %args );
if ( $bin && !-e $bin ) { # $bin is set, but we have not found it
$bin = $self->find_bin( $bin, fatal => 0, debug => 0 )
or return $log->error( "$bin was not found", %args);
}
unshift @args, $bin;
require Scalar::Util;
$tainted++ if Scalar::Util::tainted($cmd);
my $before_path = $ENV{PATH};
# instead of croaking, maybe try setting a
# very restrictive PATH? I'll err on the side of safety
# $ENV{PATH} = '';
return $log->error( "syscmd request has tainted data", %args)
if ( $tainted && !$is_safe );
if ($is_safe) {
my $prefix = "/usr/local"; # restrict the path
$prefix = "/opt/local" if -d "/opt/local";
$ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin:$prefix/bin:$prefix/sbin";
}
my $r;
eval {
if ( defined $p{timeout} ) {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm $p{timeout};
};
#$r = system $cmd;
$r = `$cmd 2>&1`;
alarm 0 if defined $p{timeout};
};
if ($EVAL_ERROR) {
if ( $EVAL_ERROR eq "alarm\n" ) {
$log->audit("timed out");
}
else {
return $log->error( "unknown error '$EVAL_ERROR'", %args);
}
}
$ENV{PATH} = $before_path; # set PATH back to original value
my @caller = caller;
return $self->syscmd_exit_code( $r, $CHILD_ERROR, \@caller, \%args );
}
sub syscmd_exit_code {
my $self = shift;
my ($r, $err, $caller, $args) = @_;
$log->audit( "r: $r" );
my $exit_code = sprintf ("%d", $err >> 8);
return 1 if $exit_code == 0; # success
#print 'error # ' . $ERRNO . "\n"; # $! == $ERRNO
$log->error( "$err: $r",fatal=>0);
if ( $err == -1 ) { # check $? for "normal" errors
$log->error( "failed to execute: $ERRNO", fatal=>0);
}
elsif ( $err & 127 ) { # check for core dump
printf "child died with signal %d, %s coredump\n", ( $? & 127 ),
( $? & 128 ) ? 'with' : 'without';
}
return $log->error( "$err: $r", location => join( ", ", @$caller ), %$args );
};
sub yes_or_no {
my $self = shift;
my $question = shift;
my %p = validate(
@_,
{ 'timeout' => { type => SCALAR, optional => 1 },
'force' => { type => BOOLEAN, optional => 1, default => 0 },
%std_opts
},
);
# for 'make test' testing
return 1 if $question eq "test";
# force if interactivity testing is not working properly.
if ( !$p{force} && !$self->is_interactive ) {
carp "not running interactively, can't prompt!";
return;
}
my $response;
print "\nYou have $p{timeout} seconds to respond.\n" if $p{timeout};
print "\n\t\t$question";
# I wish I knew why this is not working correctly
# eval { local $SIG{__DIE__}; require Term::ReadKey };
# if ($@) { #
# require Term::ReadKey;
# Term::ReadKey->import();
# print "yay, Term::ReadKey is present! Are you pleased? (y/n):\n";
# use Term::Readkey;
# ReadMode 4;
# while ( not defined ($key = ReadKey(-1)))
# { # no key yet }
# print "Got key $key\n";
# ReadMode 0;
# };
if ( $p{timeout} ) {
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm $p{timeout};
do {
print "(y/n): ";
$response = lc(<STDIN>);
chomp($response);
} until ( $response eq "n" || $response eq "y" );
alarm 0;
};
if ($@) {
$@ eq "alarm\n" ? print "timed out!\n" : carp;
}
return ($response && $response eq "y") ? 1 : 0;
}
do {
print "(y/n): ";
$response = lc(<STDIN>);
chomp($response);
} until ( $response eq "n" || $response eq "y" );
( run in 1.661 second using v1.01-cache-2.11-cpan-39bf76dae61 )