1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
package Logger;
use strict;
use Thread::Queue;
use XML::Writer;
use Encode qw(decode encode);
use Time::HiRes qw(clock_gettime CLOCK_MONOTONIC);
sub new {
my ($class) = @_;
my $logFile = defined $ENV{LOGFILE} ? "$ENV{LOGFILE}" : "/dev/null";
my $log = new XML::Writer(OUTPUT => new IO::File(">$logFile"));
my $self = {
log => $log,
logQueue => Thread::Queue->new()
};
$self->{log}->startTag("logfile");
bless $self, $class;
return $self;
}
sub close {
my ($self) = @_;
$self->{log}->endTag("logfile");
$self->{log}->end;
}
sub drainLogQueue {
my ($self) = @_;
while (defined (my $item = $self->{logQueue}->dequeue_nb())) {
$self->{log}->dataElement("line", sanitise($item->{msg}), 'machine' => $item->{machine}, 'type' => 'serial');
}
}
sub maybePrefix {
my ($msg, $attrs) = @_;
$msg = $attrs->{machine} . ": " . $msg if defined $attrs->{machine};
return $msg;
}
sub nest {
my ($self, $msg, $coderef, $attrs) = @_;
print STDERR maybePrefix("$msg\n", $attrs);
$self->{log}->startTag("nest");
$self->{log}->dataElement("head", $msg, %{$attrs});
my $now = clock_gettime(CLOCK_MONOTONIC);
$self->drainLogQueue();
eval { &$coderef };
my $res = $@;
$self->drainLogQueue();
$self->log(sprintf("(%.2f seconds)", clock_gettime(CLOCK_MONOTONIC) - $now));
$self->{log}->endTag("nest");
die $@ if $@;
}
sub sanitise {
my ($s) = @_;
$s =~ s/[[:cntrl:]\xff]//g;
$s = decode('UTF-8', $s, Encode::FB_DEFAULT);
return encode('UTF-8', $s, Encode::FB_CROAK);
}
sub log {
my ($self, $msg, $attrs) = @_;
chomp $msg;
print STDERR maybePrefix("$msg\n", $attrs);
$self->drainLogQueue();
$self->{log}->dataElement("line", $msg, %{$attrs});
}
1;
|
