package Tickit::Widget::LogAny;
# ABSTRACT: display log output in a Tickit window
use strict;
use warnings;
use parent qw(Tickit::ContainerWidget);
our $VERSION = '0.005';
=head1 NAME
Tickit::Widget::LogAny - log message rendering
=head1 VERSION
version 0.005
=head1 SYNOPSIS
#!/usr/bin/env perl
use strict;
use warnings;
use Tickit;
use Tickit::Widget::LogAny;
use Log::Any qw($log);
my $tickit = Tickit->new(
root => Tickit::Widget::LogAny->new(
stderr => 1,
)
);
print STDERR "print to STDERR\n";
printf STDERR "printf(...) to %s", 'STDERR';
warn "a warning\n";
warn "a warning with no \\n";
$log->trace('trace message');
$log->info('info message');
$log->debug('debug message');
$log->notice('notice message');
$log->warn('warn message');
$log->error('error message');
$log->critical('critical message');
$tickit->run;
=head1 DESCRIPTION
Provides basic log rendering, with optional C<warn> / C<STDERR> capture.
=begin HTML
<p>Basic rendering:</p>
<p><img src="http://tickit.perlsite.co.uk/cpan-screenshot/tickit-widget-logany-basic.png" alt="Log::Any output displayed in Tickit widget" width="663" height="208"></p>
<p>Stack trace popup:</p>
<p><img src="http://tickit.perlsite.co.uk/cpan-screenshot/tickit-widget-logany-stacktrace.png" alt="Log message with stack trace popup display using Tickit desktop layout" width="675" height="362"></p>
=end HTML
Activating any line in the list of log messages (typically by pressing C<Enter>) will
show the stack trace for that entry. Use the OK button to close (typically by pressing
C<Tab>, then C<Enter>).
=cut
use Log::Any qw($log);
use Log::Any::Adapter;
use Log::Any::Adapter::Tickit;
use Log::Any::Adapter::Util ();
use Variable::Disposition qw(dispose retain retain_future);
use POSIX qw(strftime);
use Text::Wrap ();
use Syntax::Keyword::Try;
use Tickit::Utils qw(textwidth substrwidth);
use Tickit::Style;
use Tickit::Widget::Table;
use Tickit::Widget::VBox;
use Tickit::Widget::Static;
use Tickit::Widget::Frame;
use Tickit::Widget::Button;
use constant WIDGET_PEN_FROM_STYLE => 1;
BEGIN {
style_definition base =>
date_fg => 'white',
date_sep_fg => 'white',
time_fg => 6,
time_sep_fg => 'white',
ms_fg => 6,
ms_sep_fg => 'white',
severity_emergency_fg => 'hi-red',
severity_alert_fg => 'hi-red',
severity_critical_fg => 'hi-red',
severity_error_fg => 'hi-red',
severity_warning_fg => 'red',
severity_notice_fg => 'green',
severity_info_fg => 'green',
severity_debug_fg => 'grey',
severity_trace_fg => 'grey',
subname_fg => 'hi-blue',
subname_b => 1,
;
}
=head1 METHODS
=cut
sub lines { 1 }
sub cols { 1 }
=head2 new
Takes the following named parameters:
=over 4
=item * warn - if true, will install a handler for warn()
=item * stderr - if true, will install a handler for all STDERR output
=item * scroll - if true (default), will attempt to scroll the window on new entries
=item * max_entries - will limit the number of entries we'll store, default is 5000, set to 0 for no limit
=back
=cut
sub new {
my $class = shift;
my %args = @_;
my $log_storage = Adapter::Async::OrderedList::Array->new;
Log::Any::Adapter->set('Tickit', adapter => $log_storage);
my $max_entries = delete($args{max_entries}) // 5000;
my $io_async = delete $args{io_async};
my $lines = delete $args{lines};
my $warn = delete $args{warn};
my $stderr = delete $args{stderr};
my $scroll = exists $args{scroll} ? delete $args{scroll} : 1;
my $self = $class->SUPER::new(%args);
$log_storage->bus->subscribe_to_event(
splice => $self->curry::weak::on_splice,
);
$self->{log_storage} = $log_storage;
$self->{lines} = $lines if $lines;
$self->{scroll} = $scroll;
$self->{log} = [];
$self->{table} = Tickit::Widget::Table->new(
class => 'log_entries',
adapter => $self->log_storage,
on_activate => $self->curry::weak::show_stacktrace,
failure_transformations => [
sub { '' }
],
columns => [ {
label => 'Timestamp',
width => 23,
transform => sub {
my ($row, $col, $cell) = @_;
return Future->done('') unless defined $cell && length $cell;
my @date = $self->get_style_pen('date')->getattrs;
my @date_sep = $self->get_style_pen('date_sep')->getattrs;
my @time = $self->get_style_pen('time')->getattrs;
my @time_sep = $self->get_style_pen('time_sep')->getattrs;
my @ms = $self->get_style_pen('ms')->getattrs;
my @ms_sep = $self->get_style_pen('ms_sep')->getattrs;
Future->done(
String::Tagged->new(
sprintf '%s.%03d', strftime('%Y-%m-%d %H:%M:%S', localtime $cell), 1000 * ($cell - int($cell))
)
->apply_tag( 0, 4, @date)
->apply_tag( 4, 1, @date_sep)
->apply_tag( 5, 2, @date)
->apply_tag( 7, 1, @date_sep)
->apply_tag( 8, 2, @date)
->apply_tag(11, 2, @time)
->apply_tag(13, 1, @time_sep)
->apply_tag(14, 2, @time)
->apply_tag(16, 1, @time_sep)
->apply_tag(17, 2, @time)
->apply_tag(19, 1, @ms_sep)
->apply_tag(20, 3, @ms)
)
}
}, {
label => 'Severity',
width => 9,
transform => sub {
my ($row, $col, $cell) = @_;
$self->{severity_style}{$cell} // Future->done('')
}
}, {
label => 'Category',
width => 24
}, {
label => 'Message'
} ],
item_transformations => [
sub {
my ($idx, $item) = @_;
Future->done([ map $_ // '', @{$item}{qw(timestamp severity category message)} ])
}
]
);
$log->debug("Created table");
# Take over warn statements if requested
$SIG{__WARN__} = sub {
my ($txt) = @_;
s/\v+//g for $txt;
$log->warn($txt)
} if $warn;
if($stderr) {
require Tie::Tickit::LogAny::STDERR;
tie *STDERR, 'Tie::Tickit::LogAny::STDERR';
}
# Just handled via STDERR for now
# if($io_async) {
# require IO::Async::Notifier;
# open $IO::Async::Notifier::DEBUG_FD, '>', \my $str or die $!;
#
# }
$self;
}
sub update_severity_styles {
my ($self) = @_;
my %severity;
for my $severity (Log::Any::Adapter::Util::logging_methods) {
my @style = $self->get_style_pen('severity_' . $severity)->getattrs;
die "Bad style - $severity ($@)" unless @style;
$severity{$severity} =
Future->done(
String::Tagged->new(
$severity
)
->apply_tag( 0, -1, @style)
);
}
$self->{severity_style} = \%severity;
$self
}
sub on_splice {
my ($self, $ev, $idx, $len, $data, $spliced) = @_;
return unless $self->max_entries;
retain_future(
$self->log_storage->count->then(sub {
my ($rows) = @_;
my $len = $rows - $self->max_entries;
return Future->done if $len <= 0;
$self->log_storage->splice(
0, $len, []
)
})
)
}
sub max_entries { shift->{max_entries} }
sub log_storage { shift->{log_storage} }
sub window_gained {
my ($self, $win) = @_;
$self->SUPER::window_gained($win);
$self->update_severity_styles;
my $child = $win->make_sub(
1, 0, $win->lines, $win->cols
);
$self->{table}->set_window($child);
}
sub children { shift->{table} }
sub render_to_rb {
my ($self, $rb, $rect) = @_;
my $win = $self->window or return;
$rb->clear;
$rb->text_at(0,0, "Level: all Category: all Filter: ", $self->get_style_pen);
}
sub show_stacktrace {
my ($self, $id, $items) = @_;
my ($item) = @$items;
my ($holder, $cleanup) = $self->stacktrace_holder_widget;
{
local $Text::Wrap::columns = $holder->window->cols;
my @text = map { split /\n/, $_ } Text::Wrap::wrap('', '', $item->{message});
$holder->add(Tickit::Widget::Static->new(text => $_)) for @text;
}
my $tbl;
$tbl = Tickit::Widget::Table->new(
columns => [
{ label => 'Location', transform => sub {
my ($row, $col, $cell) = @_;
$cell =~ s{^\Q$_/}{} for @INC;
Future->done($cell)
} },
{ label => 'Context', width => 8 },
{ label => 'Sub', transform => sub {
my ($row, $col, $cell) = @_;
my $w = $tbl->column_width($col) - textwidth($cell);
$cell = '...' . substrwidth($cell, 3-$w) if $w < 0;
my $pos = rindex($cell, '::') or return Future->done($cell);
Future->done(
String::Tagged->new(
$cell
)->apply_tag(
$pos + 2, -1, $self->get_style_pen('subname')->getattrs
)
)
} },
],
failure_transformations => [
sub { '' }
],
item_transformations => [
sub {
my ($idx, $item) = @_;
Future->done([
$item->{filename} . ':' . $item->{line},
@{$item}{qw(ctx sub)}
])
}
]
);
$tbl->adapter->push(map $_->{stack}, @$items);
$holder->add($tbl, expand => 1);
my $win = $self->window;
$holder->add(
Tickit::Widget::Button->new(
class => 'stacktrace_ok',
style => { linetype => 'none' },
label => 'OK',
on_click => sub {
eval {
$cleanup->();
1
} or warn "Failed to do cleanup - $@";
$win->close;
$win->tickit->later(sub {
try {
dispose $holder;
} catch {
warn "Failed to dispose vbox - $@";
}
});
}
)
);
retain $holder;
}
sub stacktrace_holder_widget {
my ($self, $code) = @_;
my $container = $self;
$container = $container->parent while !$container->isa('Tickit::Widget::FloatBox') && !$container->isa('Tickit::Widget::Layout::Desktop') && $container->can('parent') && $container->parent;
$container = $self unless $container;
my $cleanup = sub { ... };
retain(my $vbox = Tickit::Widget::VBox->new(style => { spacing => 1 }));
my $win = $self->window;
if($container->isa('Tickit::Widget::FloatBox')) {
$container->add_float(
child => $vbox
)
} elsif($container->isa('Tickit::Widget::Layout::Desktop')) {
my $panel = $container->create_panel(
label => 'Stack trace',
lines => 20,
cols => 60,
top => 5,
left => 5,
);
$panel->add($vbox);
$cleanup = sub {
$panel->close;
$win->tickit->later(sub {
try {
dispose $vbox;
dispose $panel;
} catch {
warn "Failed - $@";
}
});
$win->expose;
};
} else {
# We don't have any suitable float holders, so we'll just overlay this
# using our window as a parent. This next set of measurements assumes we
# have a bit of space to play with - if we don't, I'm not sure how best
# to handle this: use the root window instead, or just bail out?
my $float = $win->make_float(
2,
2,
$win->lines - 4,
$win->cols - 4
);
# Need to hold on to the top widget in the new hierarchy
retain(my $frame = Tickit::Widget::Frame->new(
child => $vbox,
title => 'Stack trace',
style => { linetype => 'single' }
));
$frame->set_window($float);
$float->show;
# We're responsible for disposing the $frame object, since we retained
# it earlier.
$cleanup = sub {
$frame->set_window(undef);
$float->close;
$win->tickit->later(sub {
try {
dispose $frame;
dispose $vbox;
} catch {
warn "Failed to dispose frame - $@";
}
$win->expose;
})
};
}
return $vbox, $cleanup;
}
1;
__END__
=head1 SEE ALSO
=over 4
=item * L<Log::Any>
=item * L<Log::Any::Adapter::Tickit>
=item * L<Tie::Tickit::STDERR>
=back
=head1 AUTHOR
Tom Molesworth <TEAM@cpan.org>
=head1 LICENSE
Copyright Tom Molesworth 2014-2015. Licensed under the same terms as Perl itself.