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