X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FObject-Remote.git;a=blobdiff_plain;f=lib%2FObject%2FRemote%2FLogging%2FLogger.pm;h=e9f1350d7623e755799242d510f46c90b4a65f9d;hp=5c8295c4632a3779709ae585d76665f41e5785fb;hb=515662654de237f5d17c6d3c7169b6a3b08c18d9;hpb=455d031ccaa22069757d53cac1e90fda622b80d0 diff --git a/lib/Object/Remote/Logging/Logger.pm b/lib/Object/Remote/Logging/Logger.pm index 5c8295c..e9f1350 100644 --- a/lib/Object/Remote/Logging/Logger.pm +++ b/lib/Object/Remote/Logging/Logger.pm @@ -2,22 +2,54 @@ package Object::Remote::Logging::Logger; use Moo; use Scalar::Util qw(weaken); +use Carp qw(croak); +#TODO sigh invoking a logger with a log level name the same +#as an attribute could happen - restrict attributes to _ prefix +#and restrict log levels to not start with out that prefix? has format => ( is => 'ro', required => 1, default => sub { '%l: %s' } ); has level_names => ( is => 'ro', required => 1 ); -has min_level => ( is => 'ro', required => 1, default => 'info' ); +has min_level => ( is => 'ro', required => 1, default => sub { 'info' } ); has max_level => ( is => 'lazy', required => 1 ); has _level_active => ( is => 'lazy' ); -sub BUILD { - my ($self) = @_; - our $METHODS_INSTALLED; - $self->_install_methods unless $METHODS_INSTALLED; +#just a stub so it doesn't get to AUTOLOAD +sub BUILD { } +sub DESTROY { } + +sub AUTOLOAD { + my $self = shift; + (my $method) = (our $AUTOLOAD =~ /([^:]+)$/); + + no strict 'refs'; + + if ($method =~ m/^_/) { + croak "invalid method name $method for " . ref($self); + } + + if ($method =~ m/^is_(.+)/) { + my $level_name = $1; + my $is_method = "is_$level_name"; + *{$is_method} = sub { shift(@_)->_level_active->{$level_name} }; + return $self->$is_method; + } + + my $level_name = $method; + *{$level_name} = sub { + my $self = shift; + unless(exists($self->_level_active->{$level_name})) { + croak "$level_name is not a valid log level name"; + } + + $self->_log($level_name, @_); + }; + + return $self->$level_name(@_); } sub _build_max_level { - my ($self) = @_; - return $self->level_names->[-1]; + my ($self) = @_; + return $self->level_names->[-1]; } sub _build__level_active { @@ -42,19 +74,6 @@ sub _build__level_active { return \%active; } -sub _install_methods { - my ($self) = @_; - my $should_log = 0; - our $METHODS_INSTALLED = 1; - - no strict 'refs'; - - foreach my $level (@{$self->level_names}) { - *{"is_$level"} = sub { shift(@_)->_level_active->{$level} }; - *{$level} = sub { shift(@_)->_log($level, @_) }; - } -} - sub _log { my ($self, $level, $content, $metadata_in) = @_; my %metadata = %$metadata_in; @@ -69,7 +88,8 @@ sub _create_format_lookup { $method = '(none)' unless defined $method; return { - '%' => '%', t => $self->_render_time($metadata->{timestamp}), + '%' => '%', 'n' => "\n", + t => $self->_render_time($metadata->{timestamp}), r => $self->_render_remote($metadata->{object_remote}), s => $self->_render_log(@$content), l => $level, c => $metadata->{controller}, p => $metadata->{package}, m => $method, @@ -92,8 +112,10 @@ sub _render_time { sub _render_remote { my ($self, $remote) = @_; - return 'local' if ! defined $remote || ! defined $remote->{connection_id}; - return 'remote #' . $remote->{connection_id}; + return 'local' unless defined $remote; + my $conn_id = $remote->{connection_id}; + $conn_id = '(uninit)' unless defined $conn_id; + return "remote #$conn_id"; } sub _render_log { @@ -153,7 +175,7 @@ Object::Remote::Logging::Logger - Format and output a log message #router will hold this logger forever #and send it all log messages - router->connect(Object::Remote::Logging::WarnLogger->new( + router->connect(Object::Remote::Logging::Logger->new( level_names => arg_levels, format => '%s at %f line %i, log level: %l' min_level => 'warn', max_level => 'error', )); @@ -317,6 +339,10 @@ Process id of the Perl interpreter that generated the log message. A literal %. +=item %n + +A newline. + =back =back