Apache-Logmonster
view release on metacpan or search on metacpan
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
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)";
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
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;
return $log->error( "FAILED to find $package sources!",fatal=>0)
unless ( -d $sub_path && chdir($sub_path) );
}
$self->install_from_source_apply_patches($src, $patches, $patch_args) or return;
# set default build targets if none are provided
if ( !@$targets[0] ) {
$log->audit( "\tusing default targets (./configure, make, make install)" );
@$targets = ( "./configure", "make", "make install" );
}
my $msg = "install_from_source: using targets\n";
foreach (@$targets) { $msg .= "\t$_\n" };
$log->audit( $msg ) if $p{debug};
# build the program
foreach my $target (@$targets) {
if ( $target =~ /^cd (.*)$/ ) {
$log->audit( "cwd: " . cwd . " -> " . $1 );
chdir($1) or return $log->error( "couldn't chdir $1: $!", %args);
next;
}
$self->syscmd( $target, %args ) or
return $log->error( "pwd: " . cwd . "\n$target failed: $!", %args );
}
# clean up the build sources
chdir $src;
$self->syscmd( "rm -rf $package", %args ) if -d $package;
$self->syscmd( "rm -rf $package/$sub_path", %args )
if defined $sub_path && -d "$package/$sub_path";
chdir $original_directory;
return 1;
}
sub install_from_source_apply_patches {
my $self = shift;
my ($src, $patches,$patch_args) = @_;
return 1 if ! $patches;
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
fatal - die on errors. This is the default, set fatal=>0 to override.
=head1 DEPENDENCIES
Perl.
Scalar::Util - built-in as of perl 5.8
Almost nothing else. A few of the methods do require certian things, like extract_archive requires tar and file. But in general, this package (Apache::Logmonster::Utility) should run flawlessly on any UNIX-like system. Because I recycle this package ...
=head1 METHODS
=over
=item new
To use any of the methods below, you must first create a utility object. The methods can be accessed via the utility object.
############################################
# Usage : use Apache::Logmonster::Utility;
# : my $util = Apache::Logmonster::Utility->new;
# Purpose : create a new Apache::Logmonster::Utility object
# Returns : a bona fide object
# Parameters : none
############################################
=item ask
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!
lib/Apache/Logmonster/Utility.pm view on Meta::CPAN
result:
the path to the pidfile (on success).
Example:
my $pidfile = $util->check_pidfile( "/var/run/changeme.pid" );
unless ($pidfile) {
warn "WARNING: couldn't create a process id file!: $!\n";
exit 0;
};
do_a_bunch_of_cool_stuff;
unlink $pidfile;
=item regexp_test
Prints out a string with the regexp match bracketed. Credit to Damien Conway from Perl Best Practices.
Example:
$util->regexp_test(
exp => 'toast',
string => 'mailtoaster rocks',
);
arguments required:
exp - the regular expression
string - the string you are applying the regexp to
result:
printed string highlighting the regexp match
=item source_warning
Checks to see if the old build sources are present. If they are, offer to remove them.
Usage:
$util->source_warning(
package => "Mail-Toaster-5.26",
clean => 1,
src => "/usr/local/src"
);
arguments required:
package - the name of the packages directory
arguments optional:
src - the source directory to build in (/usr/local/src)
clean - do we try removing the existing sources? (enabled)
timeout - how long to wait for an answer (60 seconds)
result:
1 - removed
0 - failure, package exists and needs to be removed.
=item sources_get
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.
usage:
$self->sources_get(
package => 'simscan-1.07',
site => 'http://www.inter7.com',
path => '/simscan/',
)
arguments required:
package - the software package name
site - the host to fetch it from
url - the path to the package on $site
arguments optional:
conf - hashref - values from toaster-watcher.conf
debug
This sub proved quite useful during 2005 as many packages began to be distributed in bzip format instead of the traditional gzip.
=item sudo
my $sudo = $util->sudo();
$util->syscmd( "$sudo rm /etc/root-owned-file" );
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 approp...
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.
arguments required:
arguments optional:
debug
result:
0 - failure
on success, the full path to the sudo binary
=item syscmd
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.
my $r = $util->syscmd( "gzip /tmp/example.txt" );
$r ? print "ok!\n" : print "not ok.\n";
arguments required:
cmd - the command to execute
arguments optional:
debug
fatal
result
the exit status of the program you called.
=item _try_mkdir
( run in 2.149 seconds using v1.01-cache-2.11-cpan-97f6503c9c8 )