Commit 05015359 authored by Kevin Atkinson's avatar Kevin Atkinson
Browse files

Merged in changes from tblog-2-branch:

          Move parts of libtblog into libtblog_simple.  Libtblog simple
          provided the basic logging functions but doesn't touch anything.
          Moreover including libtblog_simple doesn't automatically start
          the logging subsystem.  It also doesn't have testbed dependencies
          which mean 1) it can be used in the core testbed libraries (such
          as libdb, libtestbed) without introducing a circular dependency
          and 2) can be used independently.

          Reworked DBFatal and DBWarn to use tblog.  It will still email
          testbed-ops, however.

          Make use of the "cause" field to determine the cause of the bug.
          In particular tblog_find_error will look at the value of this
          field and report the "cause".  In the future different actions
          can be taken based on the ultimate "cause" of the bug, such as if
          testbed-ops should be notified.

          Change format of Error Message reported by libtblog.  As per the
          email "Format or Error Messages" ro testbed-dev.

          Have libtblog use its own Database handle to avoid problems with
          locked tables.

          Also set DBCONN_MAXTRIES to 3 for most important queries.  For
          queries that are not important don't send mail on error.
parent 71ec92da
......@@ -155,6 +155,7 @@ use vars qw(@ISA @EXPORT);
TBImageIDAccessCheck TBExptAccessCheck ExpLeader MarkNodeDown
SetNodeBootStatus OSFeatureSupported IsShelved NodeidToExp NodeidToExpOldReserved
UserDBInfo DBQuery DBQueryFatal DBQueryWarn DBWarn DBFatal DBErr
NewTBDBHandle DBQueryN DBQueryFatalN DBQueryWarnN DBErrN
DBQuoteSpecial UNIX2DBUID ExpState SetExpState ProjLeader
ExpNodes ExpNodeVnames ExpNodesOldReserved
DBDateTime DefaultImageID GroupLeader TBGroupUnixInfo
......@@ -224,6 +225,7 @@ use vars qw(@ISA @EXPORT);
# Must come after package declaration!
use lib '@prefix@/lib';
use libtblog_simple;
use English;
use File::Basename;
use POSIX qw(strftime);
......@@ -262,13 +264,14 @@ else {
# Set up for querying the database. Note that fork causes a reconnect
# to the DB in the child.
#
my $DB;
my @DB;
$DBQUERY_MAXTRIES = 1;
$DBCONN_MAXTRIES = 5;
@EXPORT_OK = qw($DBQUERY_MAXTRIES $DBCONN_MAXTRIES);
sub TBDBConnect()
sub TBDBConnect($)
{
my ($dbnum) = @_;
my $maxtries = $DBCONN_MAXTRIES;
#
......@@ -282,28 +285,30 @@ sub TBDBConnect()
my $dbuser = "$SCRIPTNAME:$name:$PID";
while ($maxtries) {
$DB = Mysql->connect("localhost", $DBNAME, $dbuser, "none");
if (defined($DB)) {
$DB[$dbnum] = Mysql->connect("localhost", $DBNAME, $dbuser, "none");
if (defined($DB[$dbnum])) {
last;
}
$maxtries--;
sleep(1);
}
if (!defined($DB)) {
if (!defined($DB[$dbnum])) {
print STDERR "Cannot connect to DB after several attempts!\n";
# Ensure consistent error value.
exit(-1);
}
$DB->{'dbh'}->{'PrintError'} = 0;
$DB[$dbnum]->{'dbh'}->{'PrintError'} = 0;
$Mysql::QUIET = 1;
}
TBDBConnect();
TBDBConnect(0);
sub TBdbfork()
{
select(undef, undef, undef, 0.3);
undef($DB);
TBDBConnect();
for (my $i = 0; $i < @DB; $i++) {
undef($DB[$i]);
TBDBConnect($i);
}
if ($EVENTSYS) {
EventFork();
}
......@@ -312,10 +317,19 @@ sub TBdbfork()
# To avoid keeping a mysql connection around.
sub TBDBDisconnect()
{
undef($DB);
for (my $i = 0; $i < @DB; $i++) {
undef($DB[$i]);
}
select(undef, undef, undef, 0.3);
}
# Create a new DB handle and return the handle number
sub NewTBDBHandle() {
my $dbnum = @DB;
TBDBConnect($dbnum);
return $dbnum;
}
#
# Record last DB error string.
#
......@@ -4339,21 +4353,22 @@ sub DBQueryOld($)
my($query) = $_[0];
my($result);
$result = $DB->query($query);
$result = $DB[0]->query($query);
if (! $result) {
$DBErrorString =
" Query: $query\n".
" Error: " . $DB->errstr;
" Error: " . $DB[0]->errstr;
}
return $result;
}
sub DBQuery($)
sub DBQueryN($$)
{
my($query) = $_[0];
my($dbnum, $query) = @_;
my $maxtries = $DBQUERY_MAXTRIES;
my $result;
my $db = $DB[$dbnum];
# Not really forever :-)
if (!$maxtries) {
......@@ -4361,17 +4376,17 @@ sub DBQuery($)
}
while ($maxtries) {
$result = $DB->query($query);
$result = $db->query($query);
if (! defined($result)) {
my $err = $DB->err;
my $err = $db->err;
$DBErrorString =
" Query: $query\n".
" Error: " . $DB->errstr . " ($err)";
" Error: " . $db->errstr . " ($err)";
}
if (defined($result) ||
($DB->err != 2006) && ($DB->err != 1053) && ($DB->err != 2013) &&
($DB->err != 1046)) {
($db->err != 2006) && ($db->err != 1053) && ($db->err != 2013) &&
($db->err != 1046)) {
last;
}
......@@ -4381,39 +4396,42 @@ sub DBQuery($)
}
return $result;
}
sub DBQuery($) {return DBQueryN(0,$_[0]);}
#
# Same as above, but die on error.
#
sub DBQueryFatal($)
sub DBQueryFatalN($$)
{
my($query) = $_[0];
my($dbnum, $query) = @_;
my($result);
$result = DBQuery($query);
$result = DBQueryN($dbnum, $query);
if (! $result) {
DBFatal("DB Query failed");
}
return $result;
}
sub DBQueryFatal($) {return DBQueryFatalN(0,$_[0]);}
#
# Same as above, but just send email on error. This info is useful
# to the TB system, but the caller has to retain control.
#
sub DBQueryWarn($)
sub DBQueryWarnN($$)
{
my($query) = $_[0];
my($dbnum, $query) = @_;
my($result);
$result = DBQuery($query);
$result = DBQueryN($dbnum, $query);
if (! $result) {
DBWarn("DB Query failed");
}
return $result;
}
sub DBQueryWarn($) {return DBQueryWarnN(0,$_[0]);}
#
# Warn and send email after a failed DB query. First argument is the error
......@@ -4424,16 +4442,8 @@ sub DBQueryWarn($)
sub DBWarn($;$)
{
my($message, $nomail) = @_;
my($text);
$text = "$message - In $SCRIPTNAME\n" .
"$DBErrorString\n";
print STDERR "*** $text";
if (! defined($nomail)) {
libtestbed::SENDMAIL($TBOPS, "DBError - $message", $text);
}
DBError(\&tbwarn, $message, $nomail);
}
#
......@@ -4444,10 +4454,26 @@ sub DBWarn($;$)
sub DBFatal($)
{
my($message) = $_[0];
DBError(\&tbdie, $message);
}
DBWarn($message);
#
# DBError, common parts of DBWarn and DBFatal
#
# usage: DBError(log function, message, nomail)
#
sub DBError($$;$)
{
my($f, $message, $nomail) = @_;
if (! defined($nomail)) {
libtestbed::SENDMAIL($TBOPS, "DBError - $message",
"$message - In $SCRIPTNAME\n".
"$DBErrorString\n");
}
die("\n");
$f->({cause=>'software'}, "$message:\n$DBErrorString");
}
#
......@@ -4459,7 +4485,7 @@ sub DBQuoteSpecial($)
{
my($string) = $_[0];
$string = $DB->quote($string);
$string = Mysql->quote($string);
return $string;
}
......@@ -4467,9 +4493,13 @@ sub DBQuoteSpecial($)
#
# Get the Error From the Last Database query
#
sub DBErrN($)
{
return $DB[$_[0]]->err;
}
sub DBErr()
{
return $DB->err;
return $DB[0]->err;
}
#
......@@ -5308,4 +5338,3 @@ sub TBSetNodeHistory($$$$$)
# _Always_ make sure that this 1 is at the end of the file...
1;
......@@ -56,7 +56,7 @@ LIB_STUFF = libtbsetup.pm exitonwarn.pm libtestbed.pm snmpit_intel.pm \
snmpit_foundry.pm snmpit_stack.pm snmpit_remote.pm \
snmpit_nortel.pm \
libaudit.pm libreboot.pm libosload.pm libtestbed.py \
libadminmfs.pm libtblog.pm libArchive.pm \
libadminmfs.pm libtblog.pm libtblog_simple.pm libArchive.pm \
power_mail.pm power_whol.pm
#
......
......@@ -766,7 +766,8 @@ while (1) {
$precheck = 1;
my $retval = RunAssign();
if ($retval != 0) {
fatal({type=>'extra'}, "Experiment can not be run on an empty testbed. Please fix the experiment.");
fatal({type=>'extra', cause=>'user'},
"Experiment can not be run on an empty testbed. Please fix the experiment.");
}
print("Assign succeeded on an empty testbed.\n");
$precheck = 0;
......
......@@ -13,8 +13,9 @@
BEGIN {$FAKE_SCRIPTNAME = $ARGV[0];}
use lib "@prefix@/lib";
use libtblog;
use libtblog qw(dblog *SOUT *SERR);
use libtblog qw(:DEFAULT dblog *SOUT *SERR);
tblog_set_default_cause('temp');
use strict;
......@@ -98,3 +99,11 @@ if ($exitcode) {
}
exit $exitcode;
......@@ -34,7 +34,8 @@ use Exporter;
@ISA = "Exporter";
@EXPORT = qw (tblog tberror tberr tbwarn tbwarning tbnotice tbinfo tbdebug
tbdie tblog_set_info tblog_sub_process tblog_find_error
tbdie tblog_set_info tblog_set_default_cause
tblog_sub_process tblog_find_error
tblog_capture tblog_stop_capture
tblog_new_process tblog_init_process tblog_exit
copy_hash
......@@ -43,11 +44,12 @@ use Exporter;
@EXPORT_OK = qw (dblog *SOUT *SERR);
# After package decl.
use English;
# DO NOT USE "use English" in this module
use POSIX qw(isatty setsid);
use File::Basename;
use IO::Handle;
use Text::Wrap;
use Carp;
use strict;
......@@ -56,40 +58,14 @@ use strict;
#
use lib "@prefix@/lib";
use libtestbed;
use libdb;
use libdb qw(NewTBDBHandle DBQueryN DBQueryWarnN DBQueryFatalN
DBQuoteSpecial $DBQUERY_MAXTRIES DBWarn DBFatal);
use libtblog_simple;
sub if_defined($$);
my $REAL_SCRIPTNAME = $SCRIPTNAME;
undef $SCRIPTNAME; # signal to use $ENV{TBLOG_SCRIPTNAME}
my %PRIORITY_MAP_TO_NUM;
my %PRIORITY_MAP_TO_STR;
my $REAL_SCRIPTNAME = basename($PROGRAM_NAME);
#
# Duplicate STDOUT and STDERR to SOUT and SERR respectfully, since
# tblog_capture() will redirect the real STDOUT and STDERR
#
open SOUT ,">&=STDOUT"; # Must be "&=" not "&" to avoid creating a
# new low level file descriper as the
# interacts strangly with the fork in swapexp.
autoflush SOUT 1;
open SERR ,">&=STDERR"; # Ditto
autoflush SERR 1;
#
# Make constants for the error level, the sub, prefixed with TBLOG_,
# are exported, the non-prefixed variables are used internally
#
sub TBLOG_EMERG {000} my $EMERG = 000;
sub TBLOG_ALERT {100} my $ALRET = 100;
sub TBLOG_CRIT {200} my $CRIT = 200;
sub TBLOG_ERR {300} my $ERR = 300;
sub TBLOG_WARNING {400} my $WARNING = 400;
sub TBLOG_NOTICE {500} my $NOTICE = 500;
sub TBLOG_INFO {600} my $INFO = 600;
sub TBLOG_DEBUG {700} my $DEBUG = 700;
my $DB;
#
# Internal Utility Functions
......@@ -97,13 +73,13 @@ sub TBLOG_DEBUG {700} my $DEBUG = 700;
sub check_env_def ( $ )
{
die "Environment variable \"$_[0]\" not defined." unless defined $_[0];
croak "Environment variable \"$_[0]\" not defined" unless defined $_[0];
}
sub check_env_num ( $ )
{
check_env_def $_[0];
die "Environment variable \"$_[0]\" not a positive integer."
croak "Environment variable \"$_[0]\" not a positive integer"
unless $ENV{$_[0]} =~ /^[0-9]+$/;
}
......@@ -120,17 +96,32 @@ sub check_env ()
check_env_def 'TBLOG_BASE_SCRIPTNAME';
}
sub if_defined ($$) {
return $_[0] if defined $_[0];
return $_[1] if defined $_[1];
return '';
my %CAUSE_MAP = (# Don't notify testbed-ops
temp => 'temp', # resources temp unavailable
user => 'user', # user error
# Notify testbed-ops
internal => 'software', # software bug, should not happen
software => 'software', # software problem, like a bad image
hardware => 'hardware', # hardware problem
unknown => '');
sub normalize_cause ( $ ) {
my $cause = $CAUSE_MAP{$_[0]};
croak "Unknown cause \"$cause\"" unless defined $cause;
return $cause;
}
sub oneof ($@) {
my ($to_find) = shift;
my @res = grep {$to_find eq $_} @_;
return @res > 0;
}
#
#
#
#
# Standard DBQuery functions from dblog but use private database handle
#
sub DBQuery ( $ ) {return DBQueryN($DB, $_[0]);}
sub DBQueryFatal ( $ ) {return DBQueryFatalN($DB, $_[0]);}
sub DBQueryWarn ( $ ) {return DBQueryWarnN($DB, $_[0]);}
#
# Like DBQueryFatal but also fail if the query didn't return any results
......@@ -138,7 +129,7 @@ sub oneof ($@) {
sub DBQuerySingleFatal ( $ )
{
my ($query) = @_;
my $query_result = DBQueryFatal $query;
my $query_result = DBQueryFatalN($DB, $query);
DBFatal("DB Query \"$query\" didn't return any results")
unless $query_result->numrows > 0;
my @row = $query_result->fetchrow_array();
......@@ -162,15 +153,15 @@ sub informative_scriptname();
# than call tblog_new_process
#
sub tblog_init() {
# Get priority mapping
my $query_result = DBQueryFatal "SELECT * FROM priorities";
for (my $i = 0; $i < $query_result->num_rows; $i++) {
my ($n,$v) = $query_result->fetchrow_array();
$PRIORITY_MAP_TO_STR{$n} = $v;
$PRIORITY_MAP_TO_NUM{uc $v} = $n;
$PRIORITY_MAP_TO_NUM{lc $v} = $n;
}
# Connect to database
$DB = NewTBDBHandle();
# Reset default cause
$ENV{TBLOG_CAUSE} = '';
# ...
tblog_new_process(if_defined($main::FAKE_SCRIPTNAME,
$REAL_SCRIPTNAME),
......@@ -203,6 +194,7 @@ sub tblog_new_process(@) {
#
sub tblog_init_process(@) {
my ($script, @argv) = @_;
local $DBQUERY_MAXTRIES = 3;
# Get script name
......@@ -290,6 +282,7 @@ sub tblog_set_info ( $$$ )
{
check_env();
my ($pid, $eid, $uid) = @_;
local $DBQUERY_MAXTRIES = 3;
$ENV{'TBLOG_PIDX'} =
DBQuerySingleFatal("select idx from experiments where pid='$pid' and eid='$eid'");
$ENV{'TBLOG_UID'} = $uid;
......@@ -298,6 +291,16 @@ sub tblog_set_info ( $$$ )
$ENV{TBLOG_PIDX}, $ENV{TBLOG_UID}, $ENV{TBLOG_SESSION});
}
#
# tblog_set_default_cause(cause)
#
sub tblog_set_default_cause ( $ )
{
check_env();
$ENV{TBLOG_CAUSE} = $_[0];
}
#
# tblog_exit(): Called automatically when a script exits, or explistly
# when a fake process exits.
......@@ -332,7 +335,7 @@ my $in_dblog = 0; # Used to avoid an infinite recursion when
# DBQueryFatal fails as a log entry is made to
# record the failure, which will than likely cause
# another failure and so on
sub dblog( $$@ ) {
sub dblog_real ( $$@ ) {
my ($priority, $parms, @mesg) = @_;
my $mesg = join('',@mesg);
#print SERR "===$priority $parms @mesg\n";
......@@ -340,6 +343,13 @@ sub dblog( $$@ ) {
$in_dblog = 1;
eval {
check_env();
my $cause;
$cause = normalize_cause($parms->{cause})
if defined $parms->{cause};
$cause = $priority <= $WARNING ? $ENV{TBLOG_CAUSE} : ''
unless defined $cause;
my $query =
sprintf('insert into log (stamp,pidx,uid,session,parent,invocation,script,level,sublevel,priority,inferred,cause,type,mesg) '.
'VALUES (UNIX_TIMESTAMP(now()),%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%s,%s,%s)',
......@@ -353,135 +363,29 @@ sub dblog( $$@ ) {
if_defined($parms->{sublevel}, 0),
$priority,
if_defined($parms->{inferred}, 0),
DBQuoteSpecial if_defined($parms->{cause}, ''),
DBQuoteSpecial $cause,
DBQuoteSpecial if_defined($parms->{type}, 'normal'),
DBQuoteSpecial $mesg);
my $result = DBQuery($query);
if (!$result && DBErr() == 1100) {
DBQueryFatal("LOCK TABLE log WRITE");
$result = DBQuery($query)
if ($priority <= $NOTICE) {
local $DBQUERY_MAXTRIES = 3;
my $result = DBQuery($query);
DBWarn("Could not log entry to DB, tblog_find_error may report incorrect results") unless $result;
} else {
my $result = DBQuery($query);
DBWarn("Could not log entry to DB", 1) unless $result;
}
DBFatal("DB Query failed") unless $result;
};
$in_dblog = 0;
# Print a warning on failure but don't log the results to stdout
# Print a warning on failure but don't log the results to the database
# as that is likely to fail also
print SERR format_message($WARNING, $@) if $@;
print SERR format_message(scriptname(), $WARNING, $@) if $@;
return 0 if $@;
return 1;
}
#
# tblog(priority, mesg, ...)
# tblog(priority, {parm=>value,...}, mesg, ...)
# The main log function. Logs a message to the database and print
# the message to STDERR with an approate prefix depending on the
# severity of the error. If more than one string is given for the
# message than they will concatenated. If the env. var. TBLOG_OFF
# is set to a true value than nothing will be written to the
# database, but the message will still be written to STDOUT.
# Useful parms: sublevel, cause, type
#
sub tblog( $@ ) {
my ($priority) = shift;
my $parms = {};
$parms = shift if ref $_[0] eq 'HASH';
my $mesg = join('',@_);
if (exists $PRIORITY_MAP_TO_STR{$priority}) {
# $priority already a valid priority number
} elsif (exists $PRIORITY_MAP_TO_NUM{$priority}) {
# $priority a priority string, convert to num
$priority = $PRIORITY_MAP_TO_NUM{$priority}
} else {
die "Unknown Priority \"$priority\"" unless defined $priority;
}
my $res = dblog($priority, $parms, $mesg) unless $mesg =~ /^\s+$/;
print SERR format_message($priority, $mesg);
return $res;
}
# Useful alias functions
sub tberror( @ ) {&tblog($ERR, @_)}
sub tberr( @ ) {&tblog($ERR, @_)}
sub tbwarn( @ ) {&tblog($WARNING, @_)}
sub tbwarning( @ ) {&tblog($WARNING, @_)}
sub tbnotice( @ ) {&tblog($NOTICE, @_)}
sub tbinfo( @ ) {&tblog($INFO, @_)}
sub tbdebug( @ ) {&tblog($DEBUG, @_)}
#
# Log the message to the database as an error and than die. An
# optional set of paramaters may be specified as the first paramater.
# Not exactly like die as the message bust be specified.
#
sub tbdie( @ ) {
my $parms = {};
$parms = shift if ref $_[0] eq 'HASH';
my $mesg = join('',@_);
dblog($ERR, $parms, $mesg);
tblog_stop_capture();
die format_message($ERR, $mesg);
}
#
# Format the message based on $priority
#
sub format_message ( $$ ) {
my ($priority, $mesg) = @_;
$mesg =~ s/\s+$//;
my $header;
if ($mesg =~ /\s*\*\*\*/) {
# do nothing
} elsif ($priority <= $ERR ) {
$header = "$ENV{TBLOG_SCRIPTNAME}";
} elsif ($priority == $WARNING) {