Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
emulab-devel
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
143
Issues
143
List
Boards
Labels
Service Desk
Milestones
Merge Requests
6
Merge Requests
6
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
emulab
emulab-devel
Commits
846badf8
Commit
846badf8
authored
Nov 04, 2005
by
Kevin Atkinson
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
*** empty log message ***
parent
096f72d5
Changes
9
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
700 additions
and
17 deletions
+700
-17
tbsetup/GNUmakefile.in
tbsetup/GNUmakefile.in
+2
-1
tbsetup/assign_wrapper.in
tbsetup/assign_wrapper.in
+12
-16
tbsetup/batchexp.in
tbsetup/batchexp.in
+8
-0
tbsetup/eventsys_control.in
tbsetup/eventsys_control.in
+1
-0
tbsetup/libtblog.pm.in
tbsetup/libtblog.pm.in
+601
-0
tbsetup/libtblog.sql
tbsetup/libtblog.sql
+71
-0
tbsetup/os_setup.in
tbsetup/os_setup.in
+1
-0
tbsetup/portstats.in
tbsetup/portstats.in
+1
-0
tbsetup/ptopgen.in
tbsetup/ptopgen.in
+3
-0
No files found.
tbsetup/GNUmakefile.in
View file @
846badf8
...
...
@@ -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
View file @
846badf8
...
...
@@ -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
View file @
846badf8
...
...
@@ -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
View file @
846badf8
...
...
@@ -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
0 → 100644
View file @
846badf8
#
!/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, @_));
}
#
# tblog_start_capture(): Capture all output to STDOUT and STDERR and turn
# them into log messages. Use SOUT and SERR to print to the real
# STDOUT and STDERR respectfully. Does NOT capture output of
# subprocesses. Will also install handlers for "die" and "warn";
#
# Implementation node: tie is used to catch prints to STDOUT and
# STDERR as that seams to be the only sane way to do it. "print" is
# a special function in perl and can not be overridden normally.
# Using "*print = &myprint" or even "*IO::Handle::print = &myprint"
# will only catch the calls to print without a file handle. Although
# it may be possible to catch the other type of call to print I don'
t
#
know
how
.
#
sub
tblog_start_capture
(
;@
)
{
my
(@
what
)
=
@
_
;
@
what
=
qw
(
stdout
stderr
die
warn
)
unless
@
what
;
foreach
(@
what
)
{
if
($
_
eq
'stdout'
)
{
tie
*
STDOUT
,
'libtblog'
,
\*
SOUT
;
}
elsif
($
_
eq
'stderr'
)
{
tie
*
STDERR
,
'libtblog'
,
\*
SERR
;
}
elsif
($
_
eq
'die'
)
{
#
Should
not
need
to
worry
about
parser
errors
since
the
#
handlers
will
be
set
only
after
parsing
is
done