Commit 05015359 authored by Kevin Atkinson's avatar Kevin Atkinson

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;
This diff is collapsed.
#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005 University of Utah and the Flux Group.
# All rights reserved.
#
#
# libtblog-simple: Logging library for testbed
#
# This version ...
#
package libtblog_simple;
sub import {
'libtblog'->export_to_level (1, @_);
}
package libtblog;
use Exporter;
@ISA = "Exporter";
@EXPORT = qw (tblog tberror tberr tbwarn tbwarning tbnotice tbinfo tbdebug
tbdie
TBLOG_EMERG TBLOG_ALERT TBLOG_CRIT TBLOG_ERR
TBLOG_WARNING TBLOG_NOTICE TBLOG_INFO TBLOG_DEBUG);
# After package decl.
# DO NOT USE "use English" in this module
use File::Basename;
use IO::Handle;
use Text::Wrap;
use Carp;
use strict;
use vars qw($SCRIPTNAME
$EMERG $ALRET $CRIT $ERR $WARNING $NOTICE $INFO $DEBUG
%PRIORITY_MAP_TO_STR %PRIORITY_MAP_TO_NUM);
#
# 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 this
# interacts strangly with the fork in swapexp.
autoflush SOUT 1;
open SERR ,">&=STDERR"; # Ditto
autoflush SERR 1;
#
#
#
$SCRIPTNAME = basename($0);
#
# Make constants for the error level, the sub, prefixed with TBLOG_,
# are exported, the non-prefixed variables are used internally
#
sub TBLOG_EMERG {000} $EMERG = 000;
sub TBLOG_ALERT {100} $ALRET = 100;
sub TBLOG_CRIT {200} $CRIT = 200;
sub TBLOG_ERR {300} $ERR = 300;
sub TBLOG_WARNING {400} $WARNING = 400;
sub TBLOG_NOTICE {500} $NOTICE = 500;
sub TBLOG_INFO {600} $INFO = 600;
sub TBLOG_DEBUG {700} $DEBUG = 700;
%PRIORITY_MAP_TO_STR = (000 => 'EMERG',
100 => 'ALRET',
200 => 'CRIT',
300 => 'ERR',
400 => 'WARNING',
500 => 'NOTICE',
600 => 'INFO',
700 => 'DEBUG');
while (my ($n,$v) = each %PRIORITY_MAP_TO_STR) {
$PRIORITY_MAP_TO_NUM{uc $v} = $n;
$PRIORITY_MAP_TO_NUM{lc $v} = $n;
}
#
# Utility functions
#
sub if_defined ($$) {
return $_[0] if defined $_[0];
return $_[1] if defined $_[1];
return '';
}
sub oneof ($@) {
my ($to_find) = shift;
my @res = grep {$to_find eq $_} @_;
return @res > 0;
}
sub scriptname() {
if_defined($SCRIPTNAME, $ENV{TBLOG_SCRIPTNAME});
}
#
# Dummy dblog, does nothing in this module
# Once the real "libtblog.pm" is used than this will be replaced
# with the real function which logs to the database
#
sub dblog_dummy( $$@ ) {
return 1;
}
*dblog = \&dblog_dummy;
#
# 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 {
croak "Unknown priority \"$priority\" in call to tblog";
}
my $res = dblog($priority, $parms, $mesg) unless $mesg =~ /^\s+$/;
print SERR format_message(scriptname(), $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() if exists $INC{'libtblog.pm'};
die format_message(scriptname(), $ERR, $mesg);
}
#
# Format the message based on $priority
#
sub format_message ( $$$ ) {
my ($scriptname, $priority, $mesg) = @_;
$mesg =~ s/\s+$//;
my $header;
if ($mesg =~ /\s*\*\*\*/) {
# do nothing
} elsif ($priority <= $ERR ) {
$header = "ERROR: $scriptname";
} elsif ($priority == $WARNING) {
$header = "WARNING: $scriptname";
} elsif ($priority == $NOTICE) {
$header = "$scriptname";
}
my $text;
my @mesg = split /\n/, $mesg;
if (@mesg == 1) {
$mesg[0] =~ s/^\s+//;
$mesg = $mesg[0];
}
if ($header) {
my $line = "*** $header: $mesg[0]";
if (@mesg > 1 || length($line) > $Text::Wrap::columns) {
$line = "*** $header:\n";
if (@mesg == 1) { # NOTE: $mesg[0] eq $mesg
$mesg =~ s/^\s+//;
$line .= wrap('*** ','*** ', $mesg, "\n");
} else {
foreach (@mesg) {
s/\s+$//;
$line .= "*** $_\n";
}
}
return $line;
} else {
return "$line\n";
}
} else {
if (@mesg == 1) {
return wrap ('', ' ', $mesg, "\n");
} else {
return "$mesg\n";
}
}
}
......@@ -239,6 +239,7 @@ else {
my $cmd = basename(shift @argv);
tblog_new_process($cmd, @argv);
tblog_set_default_cause('user');
my $err = '';
......@@ -270,7 +271,7 @@ close ERR;
if ($?) {
my $exit_status = $? >> 8;
tbdie({type=>'extra'}, "Parsing failed (error code $exit_status)!");
tbdie({type=>'extra', cause=>'user'}, "Parsing failed (error code $exit_status)!");
}
exit(0)
if ($impotent);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment