Apache-Logmonster
view release on metacpan or search on metacpan
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
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};
}
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
}
}
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
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
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.
############################################
# Usage : my $ask = $util->ask( "Would you like fries with that",
# default => "SuperSized!",
# timeout => 30
# );
# Purpose : prompt the user for information
#
# Returns : S - the users response (if not empty) or
# : S - the default ask or
# : S - an empty string
#
# Parameters
# Required : S - question - what to ask
# Optional : S - default - a default answer
# : I - timeout - how long to wait for a response
# Throws : no exceptions
# See Also : yes_or_no
=item extract_archive
Decompresses a variety of archive formats using your systems built in tools.
############### extract_archive ##################
# Usage : $util->extract_archive( 'example.tar.bz2' );
# Purpose : test the archiver, determine its contents, and then
# use the best available means to expand it.
# Returns : 0 - failure, 1 - success
# Parameters : S - archive - a bz2, gz, or tgz file to decompress
=item cwd_source_dir
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.
############ cwd_source_dir ###################
# Usage : $util->cwd_source_dir( "/usr/local/src" );
# Purpose : prepare a location to build source files in
# Returns : 0 - failure, 1 - success
# Parameters : S - dir - a directory to build programs in
=item check_homedir_ownership
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 "ch...
######### check_homedir_ownership ############
# Usage : $util->check_homedir_ownership();
# Purpose : repair user homedir ownership
# Returns : 0 - failure, 1 - success
# Parameters :
# Optional : I - auto - no prompts, just fix everything
# See Also : sysadmin
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.
=item chown_system
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.
############### chown_system #################
# Usage : $util->chown_system( dir=>"/tmp/example", user=>'matt' );
# Purpose : change the ownership of a file or directory
# Returns : 0 - failure, 1 - success
# Parameters : S - dir - the directory to chown
# : S - user - a system username
# Optional : S - group - a sytem group name
# : I - recurse - include all files/folders in directory?
# Comments : Uses the system chown binary
# See Also : n/a
=item clean_tmp_dir
############## clean_tmp_dir ################
# Usage : $util->clean_tmp_dir( $dir );
# Purpose : clean up old build stuff before rebuilding
# Returns : 0 - failure, 1 - success
# Parameters : S - $dir - a directory or file.
# Throws : die on failure
# Comments : Running this will delete its contents. Be careful!
=item get_mounted_drives
############# get_mounted_drives ############
# Usage : my $mounts = $util->get_mounted_drives();
# Purpose : Uses mount to fetch a list of mounted drive/partitions
# Returns : a hashref of mounted slices and their mount points.
=item archive_file
############### archive_file #################
# Purpose : Make a backup copy of a file by copying the file to $file.timestamp.
# Usage : my $archived_file = $util->archive_file( $file );
# Returns : the filename of the backup file, or 0 on failure.
# Parameters : S - file - the filname to be backed up
# Comments : none
=item chmod
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.
$util->chmod(
file_or_dir => '/etc/resolv.conf',
mode => '0755',
sudo => $sudo
)
( run in 0.620 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )