Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Build results of ba01a6e (on master)

  • Loading branch information...
commit 03cbd383a9b61db999649965dc9d023ca2b15a62 2 parents 9430fec + ba01a6e
@daotoad authored
View
3  MANIFEST
@@ -7,6 +7,7 @@ README
TODO
dist.ini
doc/Log-Lager.odp
+doc/Log-Lager.pdf
lib/Log/Lager.pm
lib/Log/Lager/CommandParser.pm
lib/Log/Lager/Message.pm
@@ -16,7 +17,5 @@ t/03-log_messages.t
t/CommandParser/01-load.t
t/CommandParser/02-parse.t
t/Message/01-load.t
-t/footest
-t/logfile
t/release-pod-coverage.t
t/release-pod-syntax.t
View
4 META.yml
@@ -17,6 +17,7 @@ meta-spec:
name: Log-Lager
requires:
Carp: 0
+ Config: 0
Data::Abridge: 0
Data::Dumper: 0
Exporter: 0
@@ -26,6 +27,7 @@ requires:
Scalar::Util: 0
Sys::Hostname: 0
Sys::Syslog: 0
+ Time::HiRes: 0
constant: 0
overload: 0
-version: 0.03
+version: 0.03.01
View
4 Makefile.PL
@@ -25,6 +25,7 @@ my %WriteMakefileArgs = (
'NAME' => 'Log::Lager',
'PREREQ_PM' => {
'Carp' => '0',
+ 'Config' => '0',
'Data::Abridge' => '0',
'Data::Dumper' => '0',
'Exporter' => '0',
@@ -34,10 +35,11 @@ my %WriteMakefileArgs = (
'Scalar::Util' => '0',
'Sys::Hostname' => '0',
'Sys::Syslog' => '0',
+ 'Time::HiRes' => '0',
'constant' => '0',
'overload' => '0'
},
- 'VERSION' => '0.03',
+ 'VERSION' => '0.03.01',
'test' => {
'TESTS' => 't/*.t t/CommandParser/*.t t/Message/*.t'
}
View
2  README
@@ -1,7 +1,7 @@
This archive contains the distribution Log-Lager,
-version 0.03:
+version 0.03.01:
Easy to use, flexible, parsable logs.
View
BIN  doc/Log-Lager.odp
Binary file not shown
View
BIN  doc/Log-Lager.pdf
Binary file not shown
View
19 lib/Log/Lager.pm
@@ -1,6 +1,6 @@
package Log::Lager;
BEGIN {
- $Log::Lager::VERSION = '0.03';
+ $Log::Lager::VERSION = '0.03.01';
}
use Data::Dumper;
@@ -103,6 +103,10 @@ sub _bitmask_to_mask_string {
return $string;
}
+# table lookup
+# May be faster -
+# Requires strings to be normalized
+# Current method handles repeats, out of order correctly.
sub _mask_string_to_bitmask {
my $string = shift;
@@ -116,6 +120,7 @@ sub _mask_string_to_bitmask {
return $mask;
}
+# speedup by moving for data out of sub/to state var
sub _convert_mask_to_bits {
my $mask = shift;
@@ -277,7 +282,6 @@ sub _parse_commands {
return $lex_masks;
}
-
sub _get_bits {
my $frame = shift;
my $flag = shift;
@@ -331,7 +335,14 @@ sub _handle_message {
my @messages;
{ no warnings 'uninitialized';
- @messages = @_ == 1 && reftype($_[0]) eq reftype(\&import) ? $_[0]->() : @_;
+ if( @_ == 1
+ && reftype($_[0]) eq 'CODE'
+ ) {
+ @messages = $_[0]->();
+ }
+ else {
+ @messages = @_;
+ }
}
my $msg;
@@ -570,7 +581,7 @@ Log::Lager - Easy to use, flexible, parsable logs.
=head1 VERSION
-version 0.03
+version 0.03.01
=head1 SYNOPSIS
View
10 lib/Log/Lager/CommandParser.pm
@@ -1,6 +1,6 @@
package Log::Lager::CommandParser;
BEGIN {
- $Log::Lager::CommandParser::VERSION = '0.03';
+ $Log::Lager::CommandParser::VERSION = '0.03.01';
}
use strict;
use warnings;
@@ -134,7 +134,7 @@ TEST:
BEGIN {
package Log::Lager::CommandResult;
BEGIN {
- $Log::Lager::CommandResult::VERSION = '0.03';
+ $Log::Lager::CommandResult::VERSION = '0.03.01';
}
use overload '""' => 'as_string';
@@ -255,7 +255,7 @@ BEGIN {
BEGIN {
package Log::Lager::Mask;
BEGIN {
- $Log::Lager::Mask::VERSION = '0.03';
+ $Log::Lager::Mask::VERSION = '0.03.01';
}
use overload '""' => 'as_string';
use constant GROUP_PAIRS => (
@@ -371,7 +371,7 @@ BEGIN {
BEGIN {
package Log::Lager::Command;
BEGIN {
- $Log::Lager::Command::VERSION = '0.03';
+ $Log::Lager::Command::VERSION = '0.03.01';
}
=pod
@@ -568,7 +568,7 @@ Log::Lager::CommandParser
=head1 VERSION
-version 0.03
+version 0.03.01
=head1 SYNOPSIS
View
135 lib/Log/Lager/Message.pm
@@ -1,13 +1,16 @@
package Log::Lager::Message;
BEGIN {
- $Log::Lager::Message::VERSION = '0.03';
+ $Log::Lager::Message::VERSION = '0.03.01';
}
use strict;
use warnings;
use Carp qw<croak>;
+use Config qw( %Config );
use Hash::Util qw<lock_hash>;
use Data::Abridge qw<abridge_items_recursive>;
+use Time::HiRes 'time';
+
use constant _ATTR => qw(
loglevel
@@ -24,13 +27,29 @@ use constant _ATTR => qw(
line_number
);
+use constant {
+ PACKAGE => 0,
+ FILE_NAME => 1,
+ LINE_NO => 2,
+ SUBROUTINE => 3,
+ HAS_ARGS => 4,
+ WANT_ARRAY => 5,
+ EVAL_TEXT => 6,
+ IS_REQUIRE => 7,
+ HINTS => 8,
+ BIT_MASK => 9,
+ HINT_HASH => 10,
+};
+
use Sys::Hostname ();
my $HOSTNAME = Sys::Hostname::hostname();
-BEGIN {
- no strict 'refs';
+BEGIN { # Install attribute methods.
+
for my $attr ( _ATTR ) {
- *{$attr} = sub { $_[0]->{$attr} };
+ my $sub = sub { $_[0]->{$attr} };
+ no strict 'refs';
+ *{$attr} = $sub;
}
}
@@ -69,7 +88,7 @@ sub _init {
$self->{callstack}
= defined $arg{callstack} ? $arg{callstack}
- : $arg{want_stack} ? $self->_fetch_callstack($offset)
+ : $arg{want_stack} ? $self->_callstack($offset)
: undef;
my ($file, $line, $pkg, $sub) = $self->_fetch_caller_info( $offset );
@@ -115,10 +134,50 @@ sub _adjust_call_stack_level {
return $level + $offset;
}
-sub _fetch_callstack {
+
+sub _clip_string {
+ my $l = length $_[0];
+
+ return $_[0] unless $l > 25;
+
+ my $h = substr $_[0], 0, 12;
+ my $t = substr $_[0], -11;
+
+ "$h...$t";
+}
+
+sub _callstack {
my $self = shift;
my $level = shift;
+ my @stack;
+ while (1) {
+ my @env;
+ my @args;
+ { package DB;
+BEGIN {
+ $DB::VERSION = '0.03.01';
+}
+ @env = caller($level);
+ @args = @DB::args if $env[ Log::Lager::Message::HAS_ARGS ];
+ }
+ last unless defined $env[0];
+
+ push @stack, {
+ args => [ map _clip_string($_),
+ map "$_", @args
+ ],
+ file_name => $env[FILE_NAME ],
+ package => $env[PACKAGE ],
+ line => $env[LINE_NO ],
+ sub => $env[SUBROUTINE],
+ wantarry => $env[WANT_ARRAY],
+ };
+
+ $level++;
+ }
+
+ \@stack;
}
sub _fetch_caller_info {
@@ -126,18 +185,16 @@ sub _fetch_caller_info {
my $level = shift;
my @info = caller($level);
- my ($file, $line, $pkg) = @info[1, 2, 0];
+ my ($file, $line, $pkg) = @info[FILE_NAME, LINE_NO, PACKAGE];
@info = caller($level+1);
- my $sub = $info[3];
-
+ my $sub = $info[SUBROUTINE];
return ( $file, $line, $pkg, $sub );
}
sub _thread_id {
- my $tcfg = exists $INC{threads};
-
- return 0 unless $tcfg;
+ return 0 unless $Config{usethreads};
+ return 0 unless defined &threads::tid;
return threads->tid();
}
@@ -168,28 +225,44 @@ sub _thread_id {
}
}
-# Generic formatter that takes a configured JSON object and a data structure
-# and applies one to the other.
-sub _general_formatter {
- my $json = shift;
+sub _header {
my $self = shift;
my $header = [
map $self->{$_}, qw/
- timestamp
- loglevel
- hostname
- process_id
- thread_id
- executable
- file_name
- line_number
- package
- subroutine
+ timestamp
+ loglevel
+ hostname
+ process_id
+ thread_id
+ executable
+ file_name
+ line_number
+ package
+ subroutine
/
];
+}
+
+# Generic formatter that takes a configured JSON object and a data structure
+# and applies one to the other.
+sub _general_formatter {
+ my $json = shift;
+ my $self = shift;
+
+ my $header = $self->_header;
+ my $message = $self->message;
- my $message = $json->encode( abridge_items_recursive( $header, @{$self->{message}} ) );
+ my @callstack = $self->{callstack}
+ ? { callstack => $self->{callstack} } : ();
+
+ my $message = $json->encode(
+ abridge_items_recursive(
+ $header,
+ @{$message},
+ @callstack,
+ )
+ );
return "$message\n";
}
@@ -209,10 +282,14 @@ sub _timestamp {
shift;
my $time = shift || time;
+ my $millis = $time - int $time;
+ $millis = int( $millis * 1000 );
+
my ( $sec, $min, $hour, $mday, $mon, $year ) = gmtime($time);
$year += 1900;
$mon++;
- return sprintf "%04d-%02d-%02d %02d:%02d:%02d Z", $year, $mon, $mday, $hour, $min, $sec;
+
+ return sprintf "%04d-%02d-%02d %02d:%02d:%02d.%03d Z", $year, $mon, $mday, $hour, $min, $sec, $millis;
}
1;
@@ -223,7 +300,7 @@ Log::Lager::Message
=head1 VERSION
-version 0.03
+version 0.03.01
=head1 SYNOPSIS
View
24 t/footest
@@ -1,24 +0,0 @@
-#!/bin/env perl
-
-use strict;
-use warnings;
-
-{ my $foo;
- open my $fh, '>', \$foo or die "Can't open lexical";
-
- print $fh "Print to my $foo\n" or warn "Bad rint";
-
- close $fh;
-
- print "FOO: $foo\n";
-}
-
-{ our $foo;
- open my $fh, '>', \$foo or die "Can't open global";
-
- print $fh "Print to our $foo\n";
-
- close $fh;
-
- print "FOO: $foo\n";
-}
View
36 t/logfile
@@ -1,36 +0,0 @@
-BEGIN MESSAGE
-[
- [
- "2011-07-19 17:33:44 Z",
- "GUTS",
- "tiny",
- 5674,
- 0,
- "t/03-log_messages.t",
- "(eval 79)",
- 9,
- "_My_::Test",
- "_My_::Test::log_me"
- ],
- "Message"
-]
-
-Exception thrown - [
- [
- "2011-07-19 17:33:44 Z",
- "GUTS",
- "tiny",
- 5674,
- 0,
- "t/03-log_messages.t",
- "(eval 79)",
- 9,
- "_My_::Test",
- "_My_::Test::log_me"
- ],
- "Message"
-]
-
-
-
-END MESSAGE
Please sign in to comment.
Something went wrong with that request. Please try again.