*** empty log message ***

tbsetup/GNUmakefile.in

@@ -54,7 +54,8 @@ 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 \
-		  power_mail.pm power_whol.pm
+		  power_mail.pm power_whol.pm \
+		  libtblog.pm
 
 #
 # Force dependencies on the scripts so that they will be rerun through

tbsetup/assign_wrapper.in

@@ -112,6 +112,7 @@ use libdb;
 use libtestbed;
 use Node;
 use libadminctrl;
+use libtblog;
 
 #
 # assign_wrapper Settings
@@ -189,8 +190,7 @@ sub fatal ($)
 {
     my($message) = @_;
 
-    print STDERR "*** $0:\n".
-	         "    $message\n";
+    tberror $message;
 
     # We next go to the END block below.
     exit($WRAPPER_FAILED);
@@ -211,8 +211,7 @@ END {
     }
     
     if ($warnings > 0) {
-	print STDERR "*** $0:\n".
-	             "    $warnings warnings.\n";
+	tbwarn "$warnings.\n";
 
 	$exitcode |= $WRAPPER_FAILED;
     }
@@ -889,8 +888,7 @@ sub RunAssign ()
 	#
         POSIX::setsid();
 	exec("nice $cmd $cmdargs > assign.log");
-	die("*** $0:\n".
-	    "    Could not start assign!\n");
+	die "Could not start assign!\n";
     }
 
     # Check cancel flag before continuing. 
@@ -4260,18 +4258,16 @@ sub CreateTopFile()
 		# If the user had explicitly asked for these, we
 		# print a warning
 		if (virtlanemulated($lan)) {
-		    print STDERR "*** WARNING: $0: ".
-	         		 "tb-set-multiplexed not supported on ".
-	         		 "$lan since one of the nodes in $lan is ".
-	         		 "not running the standard FreeBSD image ".
-				 "(FBSD-STD)\n";
+		    tbwarn "tb-set-multiplexed not supported on ".
+			   "$lan since one of the nodes in $lan is ".
+			   "not running the standard FreeBSD image ".
+			   "(FBSD-STD)";
 		}
 		if (virtlanuseveth($lan)) {
-		    print STDERR "*** WARNING: $0: ".
-	         		 "tb-set-useveth not supported on ".
-	         		 "$lan since one of the nodes in $lan is ".
-	         		 "not running the standard FreeBSD image ".
-				 "(FBSD-STD)\n";
+		    tbwarn "tb-set-useveth not supported on ".
+	         	   "$lan since one of the nodes in $lan is ".
+	         	   "not running the standard FreeBSD image ".
+			   "(FBSD-STD)";
 		}
 		$emulated = 0;
 		$virt_lans{$lan}->{"EMULATED"} = 0;

tbsetup/batchexp.in

@@ -82,6 +82,7 @@ my $CONTROL  = "@USERNODE@";
 use lib "@prefix@/lib";
 use libdb;
 use libtestbed;
+use libtblog;
 
 my $parser   = "$TB/libexec/parse-ns";
 my $mkexpdir = "$TB/libexec/mkexpdir";
@@ -367,6 +368,11 @@ if (! DBQueryWarn("unlock tables")) {
 #
 $justexit = 0;
 
+#
+# Set error reporting info
+# 
+tblog_set_info($pid,$eid,$UID);
+
 #
 # Create a directory structure for the experiment.
 #
@@ -1017,6 +1023,8 @@ END {
     }
     my $saved_exitcode = $?;
     
+    tblog_find_error() if $?;
+
     if ($cleaning) {
 	#
 	# We are screwed; a recursive error. Someone will have to clean

tbsetup/eventsys_control.in

@@ -62,6 +62,7 @@ if ($EUID != 0) {
 use lib "@prefix@/lib";
 use libdb;
 use libtestbed;
+use libtblog;
 
 #
 # Turn off line buffering on output

tbsetup/libtblog.pm.in

+#!/usr/bin/perl -w
+
+#
+# EMULAB-COPYRIGHT
+# Copyright (c) 2005 University of Utah and the Flux Group.
+# All rights reserved.
+#
+
+#
+# libtblog: Logging library for testbed
+#
+# The very act of including libtblog in a perl script will activate
+# the logging subsystem.  Also, all output to STDOUT and STDERR will,
+# by default, be captured and turned into log messages, in addition to
+# being printed.  Handlers are also installed for die/warn.
+# To turn this feature off use tblog_stop_capture(..).
+#
+# Although the logging subsystem is activated automatically, the pid,
+# eid, and uid can not be determined automatically.  Thus the function
+# tblog_set_info(...) needs to be called to set this info.
+#
+# To create a log entry use tblog(...) or one of the shortcut function:
+# tberror, tberr, tbwarn, tbwarning, tbnotice, tbinfo, and tbdebug.
+#
+# To attempt and figure out what went wrong during a session use
+# tblog_find_error(..).
+# 
+# To turn off the database logging set the environmental variable
+# TBLOG_OFF to a true value.
+#
+
+package libtblog;
+use Exporter;
+
+@ISA = "Exporter";
+@EXPORT = qw (tblog tberror tberr tbwarn tbwarning tbnotice tbinfo tbdebug 
+	      tbdie tblog_set_info tblog_find_error
+	      tblog_capture tblog_stop_capture
+	      TBLOG_EMERG TBLOG_ALERT TBLOG_CRIT TBLOG_ERR 
+	      TBLOG_WARNING TBLOG_NOTICE TBLOG_INFO TBLOG_DEBUG);
+@EXPORT_OK = qw (*SOUT *SERR);
+
+# After package decl.
+use English;
+use POSIX qw(isatty setsid);
+use File::Basename;
+use IO::Handle;
+
+use strict;
+
+#
+# Testbed Support libraries
+#
+use lib "@prefix@/lib";
+use libtestbed;
+use libdb;
+
+my $SCRIPTNAME = basename($PROGRAM_NAME);
+my $SCRIPTNUM = 0;
+my $PARENT_INVOCATION = 0;
+
+my %PRIORITY_MAP_TO_NUM;
+my %PRIORITY_MAP_TO_STR;
+
+#
+# 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;
+
+#
+# Internal Utility Functions
+#
+
+sub check_env_def ( $ )
+{
+  die "Environment variable \"$_[0]\" not defined." unless defined $_[0];
+}
+
+sub check_env_num ( $ )
+{
+    check_env_def $_[0];
+    die "Environment variable \"$_[0]\" not a positive integer." 
+	unless $ENV{$_[0]} =~ /^[0-9]+$/;
+}
+
+sub check_env ()
+{
+    check_env_num 'TBLOG_LEVEL';
+    check_env_num 'TBLOG_SESSION';
+    check_env_num 'TBLOG_PIDX';
+    check_env_num 'TBLOG_INVOCATION';
+    check_env_num 'TBLOG_UID';
+}
+
+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;
+}
+
+#
+# Like DBQueryFatal but also fail if the query didn't return any results
+#
+sub DBQuerySingleFatal ( $ )
+{
+    my ($query) = @_;
+    my $query_result = DBQueryFatal $query;
+    DBFatal("DB Query \"$query\" didn't return any results") 
+	unless $query_result->numrows > 0;
+    my @row = $query_result->fetchrow_array();
+    return $row[0];
+}
+
+#
+# Forward Decals
+#
+
+sub dblog ( $@ );
+sub tblog ( $@ );
+
+#
+# tblog_init(): Called automatically when a script starts.  
+#
+# Will: (1) Get the unique ID for the script name, (2) get the
+# priority mapping (string -> int) from the database, (3) Creating an
+# "entring" log message in the database, (4) get the session id and
+# set up the environmental variables if they are not already set, 
+# 5) Get the invocation id, and 6) increment the level
+#
+sub tblog_init() {
+    # Get script number
+
+    my $query_result = DBQueryFatal
+	sprintf("select script from scripts where name=%s",
+		DBQuoteSpecial $SCRIPTNAME);
+    if ($query_result->num_rows > 0) {
+	$SCRIPTNUM = ($query_result->fetchrow_array())[0];
+    } else {
+	DBQueryFatal 
+	    sprintf("insert into scripts (name) values (%s)",
+		    DBQuoteSpecial $SCRIPTNAME);
+	$SCRIPTNUM = DBQuerySingleFatal 'select LAST_INSERT_ID()';
+    }
+
+    # Get priority mapping
+
+    $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;
+    }
+
+    # ...
+
+    if (defined $ENV{'TBLOG_SESSION'}) {
+	check_env();
+	$ENV{'TBLOG_LEVEL'}++;
+	$PARENT_INVOCATION = $ENV{'TBLOG_INVOCATION'};
+	dblog($NOTICE, {type => 'entering'},
+	      'Entering "', join(' ', $SCRIPTNAME, @ARGV), '"') or die;
+	my $id = DBQuerySingleFatal 'select LAST_INSERT_ID()';
+	$ENV{'TBLOG_INVOCATION'} = $id;
+	DBQueryFatal("update log set invocation=$id where seq=$id");
+    } else {
+	$ENV{TBLOG_SESSION} = 0;
+	$ENV{TBLOG_INVOCATION} = 0;
+	$ENV{TBLOG_LEVEL} = 0;
+	$ENV{TBLOG_PIDX} = 0;
+	$ENV{TBLOG_UID} = 0;
+	dblog($NOTICE, {type => 'entering'},
+	      'Entering "', join(' ', $SCRIPTNAME, @ARGV), '"') or die;
+	my $id = DBQuerySingleFatal 'select LAST_INSERT_ID()';
+	# set SESSION in database
+	$ENV{TBLOG_SESSION} = $id;
+	$ENV{TBLOG_INVOCATION} = $id;
+	DBQueryFatal("update log set session=$id,invocation=$id where seq=$id");
+    }
+}
+
+#
+# tblog_set_info(pid, eid, uid): Sets info in the database which can't
+#   be derived automatically with init.  Needs to be called at least
+#   once during a session
+#
+sub tblog_set_info ( $$$ ) 
+{
+    check_env();
+    my ($pid, $eid, $uid) = @_;
+    $ENV{'TBLOG_PIDX'} = 
+	DBQuerySingleFatal("select idx from experiments where pid='$pid' and eid='$eid'");
+    $ENV{'TBLOG_UID'} = $uid;
+    DBQueryFatal
+	sprintf('update log set pidx=%d,uid=%s where session=%s',
+		$ENV{TBLOG_PIDX}, $ENV{TBLOG_UID}, $ENV{TBLOG_SESSION});
+    print SERR "Session ID = $ENV{TBLOG_SESSION}\n";
+}
+
+#
+# tblog_exit(): Called automatically when a script exits
+#
+sub tblog_exit() {
+    return unless defined $ENV{'TBLOG_SESSION'};
+    check_env();
+    dblog($INFO, {type=>'exiting'}, "Leaving \"$SCRIPTNAME ...\"");
+}
+
+#
+# dblog(priority, [{parm=>value,...},] mesg, ...)
+#   Internal function.  Logs a message to the database.  Doesn't print
+#   anything. Will not die, instead return 0 on error, with the error
+#   message in $@.
+#   Valid parms: cause, type, fatal
+#
+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( $@ ) {
+    my ($priority, @mesg) = @_;
+    my $parms = {};
+    $parms = shift @mesg if ref $mesg[0];
+    my $mesg = join('',@mesg);
+    return if $ENV{TBLOG_OFF} || $in_dblog;
+    $in_dblog = 1;
+    eval {
+	check_env();
+	my $query = 
+	  sprintf('insert into log (stamp,pidx,uid,session,parent,invocation,script,level,priority,inferred,cause,type,mesg) '. 
+		  'VALUES (UNIX_TIMESTAMP(now()),%d,%d,%d,%d,%d,%d,%d,%d,%d,%s,%s,%s)',
+		  $ENV{TBLOG_PIDX}, 
+		  $ENV{TBLOG_UID},
+		  $ENV{TBLOG_SESSION}, 
+		  $PARENT_INVOCATION, 
+		  $ENV{TBLOG_INVOCATION},
+		  $SCRIPTNUM, 
+		  $ENV{TBLOG_LEVEL},
+		  $priority,
+		  if_defined($parms->{inferred}, 0),
+		  DBQuoteSpecial if_defined($parms->{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)
+	}
+	DBFatal("DB Query failed") unless $result;
+    };
+    $in_dblog = 0;
+    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: cause
+#
+sub tblog( $@ ) {
+    my ($priority, @rest) = @_;
+
+    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 $mesg = join('', @rest);
+    my $res = dblog($priority, @rest) unless $mesg =~ /^\s+$/;
+
+    if ($priority <= $ERR ) {
+	print SERR "*** $SCRIPTNAME:\n"."    $mesg\n";
+    } elsif ($priority == $WARNING) {
+	print SERR "*** WARNING: $mesg\n";
+    } else {
+	print SERR "$mesg\n";
+    }
+
+    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, @_)}
+
+#
+
+sub tbdie( @ ) {
+    dblog($ERR, @_);
+    tblog_stop_capture();
+    die ("*** $SCRIPTNAME:\n".
+	 "    $_[0]\n");
+}
+
+#
+# tblog_find_error([session],[store]): attempts to find the relevant error.  
+# 
+# Parameters:
+#   session: Session id to use. Defaults to the current as given by 
+#       $ENV{TVLOG_SESSION}.
+#   store: If set store the results into the database and act in
+#       a way that is safe to use in an END block, that is 
+#       (1) never die, (2) don't modify the exit code,  Will also
+#       print the results to and some additional info to STDERR
+#       for diagnosis purposed.  If not set simply print the results to
+#       STDERR.  Defaults to true unless the "session" parameter is also
+#       given, in which case default to false.
+#
+# Format of the result:
+#   <seq>: <script name>: <error msg>
+# for each relevent error
+#
+# To retrieve the results from the database:
+#   select ... where session = <Session ID> AND type = 'thecause' form log
+# The relevant errors are also flagged using "relevant" flag:
+#   select ... where session = <Session ID> AND relevant != 0 form log
+#
+sub tblog_find_error ( ;$$ ) {
+
+    my ($session,$store) = @_;
+    my $saved_exitcode = $?;
+
+    if (not defined $session) {
+        check_env();
+	$store = 1;
+	$session = $ENV{TBLOG_SESSION};
+    }
+
+    $store = 0 unless defined $store;
+
+    eval {
+
+	#
+	# Build the Tree
+	#
+	# Tree data structure:
+	# invocation = {invocation => INT, parent => INT, [{seq => int ...} || {seq => int, child => invox}]
+	
+	my $root = {invocation => 0, log => []};
+	my %lookup = (0 => $root);
+	my @log;
+	
+	my $query_result = DBQueryFatal "select seq,parent,invocation,priority,mesg,scripts.name from log natural join scripts where session = $session and priority <= $NOTICE order by seq";
+	
+	for (my $i = 0; $i < $query_result->num_rows; $i++) {
+	    
+	    my ($seq, $parent, $invocation, $priority, $mesg, $script) = $query_result->fetchrow;
+	    
+	    if (not exists $lookup{$invocation}) {
+		
+		my $p = $lookup{$parent};
+		die "Parent Doesn't Exists!" unless defined $p;
+		$lookup{$invocation} = {invocation => $invocation, parent => $parent, script=>$script, log => []};
+		push @{$p->{log}}, {seq => $invocation, child => $lookup{$invocation}};
+		
+	    }
+	    
+	    push @{$lookup{$invocation}{log}}, {seq => $seq, invocation=>$invocation, priority => $priority, mesg => $mesg};
+	    
+	}
+	
+	#
+	# Walk the Tree to find relevant errors
+	#
+	
+	my $prev_err_level = 0;
+	my @relevant;
+	
+	my $walk_tree;
+	$walk_tree = sub {
+	    
+	    my ($tree, $level) = @_;
+	    
+	    foreach (@{$tree->{log}}) {
+		
+		if (exists $_->{child}) {
+		    
+		    $walk_tree->($_->{child}, $level + 1);
+		    
+		} elsif ($_->{priority} <= $ERR) {
+		    
+		    push @relevant, $_ unless $prev_err_level > $level;
+		    
+		    $prev_err_level = $level;
+		    
+		}
+		
+	    }
+	    
+	};
+	
+	$walk_tree->($root, 0);
+	
+	# 
+	# Finally print/store the relevant errors
+	#
+	
+	my $error = '';
+	
+	foreach (@relevant) {
+	    $error .= "$_->{seq}: $lookup{$_->{invocation}}->{script}: $_->{mesg}\n";
+	}
+	$error = "No clue as to what went wrong!\n" unless length $error > 0;
+	
+	if ($store) {
+	    print SERR "**** Experimental information, please ignore ****\n";
+	    print SERR "Session ID = $ENV{TBLOG_SESSION}\n";
+	    print SERR "Likely Cause of the Problem:\n";
+	    print SERR $error;
+	    print SERR "**** End experimental information ****\n";
+	    chop $error;
+	    dblog $NOTICE, {type=>'thecause'}, $error;
+	    DBQueryFatal(sprintf("update log set relevant=1 where seq in (%s)",
+				 join(',', map {$_->{seq}} @relevant))) if @relevant;
+	} else {
+	    print SERR $error;
+	}
+    };
+
+    if ($@) {
+	my $err = $@;
+	eval {SENDMAIL(TB_OPSEMAIL, "tblog_find_error failed",
+		       "Experiment: $ENV{TBLOG_PIDX}\n".
+		       "User: $ENV{TBLOG_UID}\n".
+		       "Session: $ENV{TBLOG_SESSION}\n".
+		       "Script: $SCRIPTNAME\n".
+		       "\n".
+		       "$err\n")};
+	if ($store) {
+	    eval {dblog $WARNING, {type=>'thecause'}, 
+		    "tblog_find_error failed: $err" };
+	} else {
+	    $? = $saved_exitcode;
+	    die;
+	}
+    }
+    $? = $saved_exitcode;
+}
+
+#
+# Perl Tie Methods, see perltie(1)
+#
+
+sub TIEHANDLE {
+    my ($classname, $glob) = @_;
+    bless \$glob, $classname;
+}
+
+sub PRINT {
+    my $this = shift;
+    print {$$this} @_;
+    local $_ = join '', @_; # NOTE: This doesn't take into account "$,"
+                            # or output_field_separator
+    s/\n$//;
+    if (/warning:/i) {
+      dblog $WARNING, {inferred=>2}, $_;
+    } elsif (/\*\*\*/) {
+      dblog $ERR, {inferred=>2}, $_;
+    } else {
+      dblog $INFO, {inferred=>3}, $_;
+    }
+}
+
+sub PRINTF {
+    my ($this,$format) = (shift, shift);
+    &PRINT($this, sprintf($format, @_));
+}
+