nixpkgs/nixos/lib/test-driver/Logger.pm

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;