use POSIX qw (setsid);
use File::Spec;
use Carp;
+use Term::ReadKey;
use OSDep;
use Display;
+our $pipe;
+
our @EXPORT = qw (
+ CheckParms
EnterDaemonMode
Execute
GetChildren
+ GetPassword
InArray
+ LoadAvg
PageOutput
PipeOutput
PipeOutputArray
ReadFile
+ RequiredFields
RedirectOutput
StartPipe
Stats
Usage
);
-sub EnterDaemonMode (;$$$) {
+sub _restoreTerm() {
+ # In case the user hits Ctrl-C
+ print "\nControl-C\n";
+
+ ReadMode 'normal';
+
+ exit;
+} # _restoreTerm
+
+sub CheckParms($$) {
+ my ($requiredFields, $rec) = @_;
+
+ my $msg = RequiredFields($requiredFields, $rec);
+
+ my $function = (caller(1))[3];
+ my $calledFrom = (caller(2))[3];
+ my $lineNbr = (caller(2))[2];
+
+ croak "Internal error: $function called from $calledFrom:$lineNbr\n\nThe field $msg" if $msg;
+
+ return;
+} # CheckParms
+
+sub EnterDaemonMode(;$$$) {
my ($logfile, $errorlog, $pidfile) = @_;
=pod
$errorlog ||= $NULL;
my $file;
-
- if ($pidfile) {
- $pidfile = File::Spec->rel2abs ($pidfile);
- open $file, '>', $pidfile
- or warning "Unable to open pidfile $pidfile for writing - $!";
- } # if
-
# Redirect STDIN to $NULL
open STDIN, '<', $NULL
or error "Can't read $NULL ($!)", 1;
or error "Can't write to $errorlog ($!)", 1;
# Change the current directory to /
- my $ROOT = $ARCH eq "windows" ? "C:\\" : "/";
+ my $ROOT = $ARCHITECTURE eq "windows" ? "C:\\" : "/";
chdir $ROOT
or error "Can't chdir to $ROOT ($!), 1";
# Now the parent exits
exit if $pid;
-
+
# Write pidfile if specified
if ($pidfile) {
+ $pidfile = File::Spec->rel2abs ($pidfile);
+
+ open $file, '>', $pidfile
+ or warning "Unable to open pidfile $pidfile for writing - $!";
+
print $file "$$\n";
-
+
close $file;
} # if
-
+
# Set process to be session leader
setsid ()
or error "Can't start a new session ($!)", 1;
-
+
return;
} # EnterDaemonMode
-sub Execute ($) {
+sub Execute($) {
my ($cmd) = @_;
=pod
=cut
- # Save $SIG{CHLD} so we can set it to 'DEFAULT' and then restore it later.
- # Helps when you are doing process handling.
- my $sigchld = $SIG{CHLD};
-
local $SIG{CHLD} = 'DEFAULT';
my @output = `$cmd`;
my $status = $?;
-
- local $SIG{CHLD} = $sigchld;
chomp @output;
- return ($status, @output);
+ return wantarray ? ($status, @output) : $status;
} # Execute
-sub GetChildren (;$) {
+sub GetChildren(;$) {
my ($pid) = @_;
=pod
chomp @output;
- foreach (@output) {
+ for (@output) {
# Skip the pstree process and the parent process - we want only
# our children.
next if /pstree/ or /\($pid\)/;
if (/\((\d+)\)/) {
push @children, $1;
} # if
- } # foreach
+ } # for
return @children;
} # GetChildren
-sub InArray ($@) {
+sub GetPassword(;$) {
+ my ($prompt) = @_;
+
+=pod
+
+=head2 GetPassword (;$prompt)
+
+Prompt for a password
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $prompt
+
+Prompt string to use (Default: "Password:")
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item $password
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ $prompt ||= 'Password';
+
+ my $password = '';
+
+ local $| = 1;
+
+ print "$prompt:";
+
+ $SIG{INT} = \&_restoreTerm;
+
+ ReadMode 'cbreak';
+
+ while () {
+ my $key;
+
+ while (not defined ($key = ReadKey -1)) { }
+
+ if ($key =~ /(\r|\n)/) {
+ print "\n";
+
+ last;
+ } # if
+
+ # Handle backspaces
+ if ($key eq chr(127)) {
+ unless ($password eq '') {
+ chop $password;
+
+ print "\b \b";
+ } # unless
+ } else {
+ print '*';
+
+ $password .= $key;
+ } # if
+ } # while
+
+ ReadMode 'restore'; # Reset tty mode before exiting.
+
+ $SIG{INT} = 'DEFAULT';
+
+ return $password;
+} # GetPassword
+
+sub InArray($@) {
my ($item, @array) = @_;
=pod
=cut
- foreach (@array) {
+ for (@array) {
return $TRUE if $item eq $_;
- } # foreach
+ } # for
return $FALSE;
} # InArray
-our $pipe;
+sub LoadAvg () {
+
+=pod
+
+=head2 LoadAvg ()
+
+Return an array of the 1, 5, and 15 minute load averages.
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item none
+
+=back
-sub StartPipe ($;$) {
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item An array of the 1, 5, and 15 minute load averages in a list context.
+In a scalar context just the 1 minute load average.
+
+=back
+
+=for html </blockquote>
+
+=cut
+ # TODO: Make it work on Windows...
+ return if $^O =~ /win/i;
+
+ open my $loadAvg, '<', '/proc/loadavg'
+ or croak "Unable to open /proc/loadavg\n";
+
+ my $load = <$loadAvg>;
+
+ close $loadAvg;
+
+ my @loadAvgs = split /\s/, $load;
+
+ if (wantarray) {
+ return @loadAvgs;
+ } else {
+ return $loadAvgs[0]; # This is the 1 minute average
+ }
+} # LoadAvg
+
+sub StartPipe($;$) {
my ($to, $existingPipe) = @_;
=pod
if ($existingPipe) {
close $existingPipe;
-
+
open $existingPipe, '|-', $to
or error "Unable to open pipe - $!", 1;
-
+
return $existingPipe;
} else {
open $pipe, '|-', $to
} # if
} # StartPipe
-sub PipeOutputArray ($@) {
+sub PipeOutputArray($@) {
my ($to, @output) = @_;
=pod
=item $to
String representing the other end of the pipe to pipe @output to
-
+
=item @output
Output to pipe
=cut
- open my $pipe, "|$to"
+ open my $pipe, '|-', $to
or error "Unable to open pipe - $!", 1;
- foreach (@output) {
+ for (@output) {
chomp;
print $pipe "$_\n";
- } # foreach
+ } # for
return close $pipe;
} # PipeOutputArray
-sub PipeOutput ($;$) {
+sub PipeOutput($;$) {
my ($line, $topipe) = @_;
=pod
return;
} # PipeOutput
-sub StopPipe (;$) {
+sub StopPipe(;$) {
my ($pipeToStop) = @_;
=pod
$pipeToStop ||= $pipe;
close $pipeToStop if $pipeToStop;
+
+ return;
} # StopPipe
-sub PageOutput (@) {
+sub PageOutput(@) {
my (@output) = @_;
-
+
=pod
=head2 PageOutput (@ouput)
PipeOutputArray $ENV{PAGER}, @output;
} else {
print "$_\n"
- foreach (@output);
+ for (@output);
} # if
-
+
return;
} # PageOutput
-sub RedirectOutput ($$@) {
+sub RedirectOutput($$@) {
my ($to, $mode, @output) = @_;
-
+
=pod
=head2 RedirectOutput ($to, @ouput)
open my $out, $mode, $to
or croak "Unable to open $to for writing - $!";
- foreach (@output) {
+ for (@output) {
chomp;
print $out "$_\n";
- } # foreach
+ } # for
+
+ close $out;
- return;
+ return;
} # RedirectOutput
-sub ReadFile ($) {
+sub ReadFile($) {
my ($filename) = @_;
=pod
open my $file, '<', $filename
or error "Unable to open $filename ($!)", 1;
-
+
if (wantarray) {
local $/ = "\n";
my @lines = <$file>;
-
+
close $file
or error "Unable to close $filename ($!)", 1;
-
+
my @cleansed_lines;
-
- foreach (@lines) {
+
+ for (@lines) {
chomp;
chop if /\r/;
push @cleansed_lines, $_ if !/^#/; # Discard comment lines
- } # foreach
-
+ } # for
+
return @cleansed_lines;
} else {
- local $/;
-
+ local $/ = undef;
+
return <$file>;
} # if
} # ReadFile
-sub Stats ($;$) {
+sub Stats($;$) {
my ($total, $log) = @_;
=pod
=item $log
-Logger object to log stats to (if specified)
+Logger object to log stats to (if specified). Note: if the Logger object has
+errors or warnings then they will be automatically included in the output.
=back
=cut
my $msg = "$FindBin::Script Run Statistics:";
-
- if (scalar keys %$total) {
+
+ if ($log and ref $log eq 'Logger') {
+ $total->{errors} = $log->{errors};
+ $total->{warnings} = $log->{warnings};
+ } # if
+
+ if (keys %$total) {
# Display statistics (if any)
if ($log) {
$log->msg ($msg);
display $msg;
} # if
- foreach (sort keys %$total) {
- $msg = $$total{$_} . "\t $_";
-
+ for (sort keys %$total) {
+ $msg = $total->{$_} . "\t $_";
+
if ($log) {
- $log->msg ($$total{$_} . "\t $_");
+ $log->msg ($total->{$_} . "\t $_");
} else {
display $msg;
} # if
- } # foreach
+ } # for
} # if
-
+
return;
} # Stats
-sub Usage (;$) {
+sub Usage(;$) {
my ($msg) = @_;
=pod
=cut
- display $msg
- if $msg;
+ display $msg if $msg;
system "perldoc $0";
exit 1;
} # Usage
+sub RequiredFields($$) {
+
+=pod
+
+=head2 RequiredFields($total, $log)
+
+Check if a list of fields are contained in a hash
+
+Parameters:
+
+=for html <blockquote>
+
+=over
+
+=item $fields
+
+Array reference to a list of field names that are required
+
+=item $rec
+
+Hash reference whose key values we are checking
+
+=back
+
+=for html </blockquote>
+
+Returns:
+
+=for html <blockquote>
+
+=over
+
+=item Message
+
+Returns either an empty string or a string naming the first missing required
+field
+
+=back
+
+=for html </blockquote>
+
+=cut
+
+ my ($fields, $rec) = @_;
+
+ for my $fieldname (@$fields) {
+ my $found = 0;
+
+ for (keys %$rec) {
+ if ($fieldname eq $_) {
+ $found = 1;
+ last;
+ } # if
+ } # for
+
+ return "$fieldname is required" unless $found;
+ } # for
+
+ return;
+} # RequiredFields
+
END {
StopPipe;
} # END
projects / clearscm.git / blobdiff