File Coverage

blib/lib/Circle/Loggable.pm
Criterion Covered Total %
statement 42 201 20.9
branch 0 58 0.0
condition 0 18 0.0
subroutine 14 33 42.4
pod 0 10 0.0
total 56 320 17.5


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2014 -- leonerd@leonerd.org.uk
4              
5             package Circle::Loggable;
6              
7 4     4   42 use strict;
  4         4  
  4         94  
8 4     4   12 use warnings;
  4         5  
  4         114  
9 4     4   14 use base qw( Circle::Commandable Circle::Configurable );
  4         4  
  4         289  
10              
11 4     4   16 use File::Basename qw( dirname );
  4         4  
  4         178  
12 4     4   15 use File::Path qw( make_path );
  4         4  
  4         182  
13 4     4   14 use POSIX qw( strftime mktime );
  4         3  
  4         29  
14              
15             __PACKAGE__->APPLY_Inheritable_Setting( log_enabled =>
16             description => "Enable logging of events",
17             type => 'bool',
18             );
19              
20             __PACKAGE__->APPLY_Inheritable_Setting( log_path =>
21             description => "Path template for log file name",
22             type => 'str',
23             );
24              
25 4     4   294 use Struct::Dumb qw( readonly_struct );
  4         4  
  4         31  
26              
27             # Data about the log file itself
28             readonly_struct LogId => [qw(
29             path time_start time_until itempath line_timestamp_fmt
30             )];
31              
32             # Data about logging from a particular item
33             readonly_struct LogCtx => [qw(
34             path_residue
35             )];
36              
37             our $NO_LOG = 0;
38              
39             sub push_log
40             {
41 0     0 0   my $self = shift;
42 0           my ( $event, $time, $args ) = @_;
43              
44 0 0         return unless $self->setting_log_enabled;
45 0 0         return if $NO_LOG;
46              
47             # Best-effort
48 0 0         eval {
49 0           my $logger = $self->logger( $time );
50              
51 0           my $ctx = $self->{logctx};
52              
53 0           $logger->log( $ctx, $time, $event, $args );
54 0           1;
55             } and return;
56              
57             {
58 0           local $NO_LOG = 1;
  0            
59 0           warn "Unable to log - $@";
60             }
61             }
62              
63             my %time_format_to_idx = (
64             Y => 5,
65             m => 4,
66             d => 3,
67             H => 2,
68             M => 1,
69             S => 0,
70             );
71              
72             # Returns a LogId and a LogCtx
73             sub split_logpath
74             {
75 0     0 0   my $self = shift;
76 0           my ( $time ) = @_;
77              
78 0           my @pcs = split m{/}, $self->enumerable_path;
79 0           shift @pcs; # trim leading /
80 0 0         @pcs or @pcs = ( "Global" );
81 0           my $path_used = 0;
82 0           my %ts_used = map { $_ => 0 } qw( Y m d H M );
  0            
83              
84 0           my @timestamp = localtime $time;
85              
86             my %formats = (
87             # Specific kinds of time format so we can track the granulity being used
88             ( map {
89 0           my $format = $_;
90             $format => sub {
91 0     0     $ts_used{$format}++;
92 0           strftime( "%$format", @timestamp )
93 0           };
94             } qw( Y m d H M ) ),
95             P => sub {
96 0     0     my ( $limit ) = @_;
97 0 0         defined $limit or $limit = @pcs;
98              
99 0           my $path_lower = $path_used;
100 0           my $path_upper = $limit;
101              
102 0 0         $path_used = $path_upper if $path_upper > $path_used;
103              
104 0   0       return join '/', map { $_ // "" } @pcs[$path_lower..$path_upper-1];
  0            
105             },
106 0           );
107              
108 0           my $path = $self->setting_log_path;
109 0           $path =~ s<%(?:{([^}]*)})?(.)>
110 0 0         {exists $formats{$2} ? $formats{$2}->($1)
111             : die "Unrecognised escape '%$2"}eg;
112              
113             # Reset to zero all the fields that aren't used
114 0   0       $ts_used{$_} or $timestamp[$time_format_to_idx{$_}] = 0 for qw( Y m d H M S );
115 0 0         $timestamp[3] or $timestamp[3] = 1; # mday is 1-based
116              
117 0           my $time_start = strftime( "%Y/%m/%d %H:%M:%S", @timestamp );
118              
119             # Increment the last timestamp field before a field not used in the file
120             # path
121 0   0       $ts_used{$_} or $timestamp[$time_format_to_idx{$_}+1]++, last for qw( m d H M S );
122 0           my $time_until = mktime @timestamp;
123              
124 0 0         my $time_fmt_day = join "/", map { $ts_used{$_} ? () : ( "\%$_" ) } qw( Y m d );
  0            
125 0 0         my $time_fmt_sec = join ":", map { $ts_used{$_} ? () : ( "\%$_" ) } qw( H M S );
  0            
126              
127             my $logid = LogId(
128             $path,
129             $time_start,
130             $time_until,
131 0           join( '/', grep { defined } @pcs[0..$path_used-1] ),
132 0           join( " ", grep { length } $time_fmt_day, $time_fmt_sec ),
  0            
133             );
134              
135             my $logctx = LogCtx(
136 0           join( '/', grep { defined } @pcs[$path_used..$#pcs] ),
  0            
137             );
138              
139 0           return ( $logid, $logctx );
140             }
141              
142             our %LOGGER_FOR_PATH;
143              
144             sub logger
145             {
146 0     0 0   my $self = shift;
147 0           my ( $time ) = @_;
148              
149 0           my ( $logid, $logctx ) = $self->split_logpath( $time );
150 0           my $path = $logid->path;
151              
152 0 0 0       if( defined $self->{logpath} and $self->{logpath} ne $path ) {
153 0           $self->close_logger;
154             }
155 0 0 0       if( defined $self->{loguntil} and $time >= $self->{loguntil} ) {
156 0           $self->close_logger;
157             }
158              
159 0   0       my $logger = $LOGGER_FOR_PATH{$path} ||= do {
160 0           my $dir = dirname( $path );
161 0 0         unless( -d $dir ) {
162 0 0         make_path( $dir, { mode => 0700 } ) or die "Cannot mkdir $dir - $!";
163             }
164              
165 0           Circle::Loggable::Backend::CircleLog->open( $logid );
166             };
167              
168 0 0         if( !defined $self->{logpath} ) {
169 0           $self->{logpath} = $path;
170 0           $self->{loguntil} = $logid->time_until;
171 0           $logger->hold_ref;
172              
173             # TODO set up a timer to expire and close the log at that time
174             }
175              
176 0           $self->{logctx} = $logctx;
177              
178 0           return $logger;
179             }
180              
181             sub close_logger
182             {
183 0     0 0   my $self = shift;
184              
185 0 0 0       my $logger = $LOGGER_FOR_PATH{$self->{logpath} // ""} or return;
186              
187 0           $logger->drop_ref;
188 0 0         if( !$logger->refcount ) {
189 0           delete $LOGGER_FOR_PATH{$self->{logpath}};
190 0           $logger->close;
191             }
192              
193 0           undef $self->{logpath};
194             }
195              
196             sub command_log
197             : Command_description("Configure logging")
198       0 0   {
199 4     4   3411 }
  4         7  
  4         18  
200              
201             sub command_log_info
202             : Command_description("Show information about logging")
203             : Command_subof('log')
204             : Command_default()
205             {
206 0     0 0 0 my $self = shift;
207 0         0 my ( $cinv ) = @_;
208              
209 0 0       0 if( $self->_setting_log_enabled_inherits ) {
    0          
210 0 0       0 $cinv->respond( "Logging is inherited (currently " . ( $self->setting_log_enabled ? "enabled" : "disabled" ) . ")" );
211             }
212             elsif( $self->setting_log_enabled ) {
213 0         0 $cinv->respond( "Logging is directly enabled" );
214             }
215             else {
216 0         0 $cinv->respond( "Logging is directly disabled" );
217             }
218              
219 0 0       0 if( $self->setting_log_enabled ) {
220 0         0 my ( $logid, $logctx ) = $self->split_logpath( time );
221              
222 0         0 $cinv->respond( "Logging to path " . $logid->path );
223 0         0 $cinv->respond( "Timestamp starts " . $logid->time_start );
224 0         0 $cinv->respond( "Timestamp until " . strftime( "%Y/%m/%d %H:%M:%S", localtime $logid->time_until ) );
225 0         0 $cinv->respond( "Line timestamp is " . $logid->line_timestamp_fmt );
226              
227 0         0 $cinv->respond( "Path residue is " . $logctx->path_residue );
228             }
229              
230 0         0 return;
231 4     4   7346 }
  4         6  
  4         20  
232              
233             sub command_log_enable
234             : Command_description("Enable logging of this item and its children")
235             : Command_subof('log')
236             {
237 0     0 0 0 my $self = shift;
238 0         0 my ( $cinv ) = @_;
239              
240 0         0 $self->setting_log_enabled( 1 );
241 0         0 $cinv->respond( "Logging enabled" );
242 0         0 return;
243 4     4   667 }
  4         5  
  4         11  
244              
245             sub command_log_disable
246             : Command_description("Disable logging of this item and its children")
247             : Command_subof('log')
248             {
249 0     0 0 0 my $self = shift;
250 0         0 my ( $cinv ) = @_;
251              
252 0         0 $self->setting_log_enabled( 0 );
253 0         0 $cinv->respond( "Logging disabled" );
254 0         0 return;
255 4     4   590 }
  4         6  
  4         13  
256              
257             sub command_log_inherit
258             : Command_description("Inherit log enabled state from parent")
259             : Command_subof('log')
260             {
261 0     0 0 0 my $self = shift;
262 0         0 my ( $cinv ) = @_;
263              
264 0         0 $self->setting_log_enabled( undef );
265 0 0       0 $cinv->respond( "Logging inherited (currently " . $self->setting_log_enabled ? "enabled" : "disabled" );
266 0         0 return;
267 4     4   675 }
  4         4  
  4         21  
268              
269             sub command_log_rotate
270             : Command_description("Rotate the current log file handle")
271             : Command_subof('log')
272             {
273 0     0 0 0 my $self = shift;
274 0         0 my ( $cinv ) = @_;
275              
276 0         0 my $path;
277 0         0 my $n_suffix = 1;
278 0         0 $n_suffix++ while -f ( $path = "$self->{logpath}.$n_suffix" );
279              
280 0 0       0 unless( rename( $self->{logpath}, $path ) ) {
281 0         0 $cinv->responderr( "Cannot rename $self->{logpath} to $path - $!" );
282 0         0 return;
283             }
284              
285 0         0 $cinv->respond( "Log file rotated to $path" );
286              
287 0         0 $self->{logger}->close;
288 0         0 undef $self->{logger};
289              
290 0         0 return;
291 4     4   959 }
  4         7  
  4         13  
292              
293             package # hide
294             Circle::Loggable::Backend::CircleLog;
295              
296 4     4   484 use POSIX qw( strftime );
  4         5  
  4         16  
297              
298             sub open
299             {
300 0     0     my $class = shift;
301 0           my ( $id ) = @_;
302              
303 0           my $path = $id->path;
304 0 0         open my $fh, ">>", $path or die "Cannot open event log $path - $!";
305 0           chmod $fh, 0600;
306              
307 0           $fh->binmode( ":encoding(UTF-8)" );
308 0           $fh->autoflush;
309              
310 0           $fh->print( "!LOG START=\"${\$id->time_start}\" ITEMS=\"${\$id->itempath}\" TIMESTAMP_FMT=\"${\$id->line_timestamp_fmt}\"\n" );
  0            
  0            
  0            
311              
312 0           return bless {
313             fh => $fh,
314             refcount => 0,
315             id => $id,
316             }, $class;
317             }
318              
319 0     0     sub refcount { shift->{refcount} }
320 0     0     sub hold_ref { shift->{refcount}++ }
321 0     0     sub drop_ref { shift->{refcount}-- }
322              
323             sub close
324             {
325 0     0     my $self = shift;
326 0 0         warn "Closing $self with references open" if $self->{refcount};
327              
328 0           close $self->{fh};
329             }
330              
331             sub log
332             {
333 0     0     my $self = shift;
334 0           my ( $ctx, $time, $event, $args ) = @_;
335              
336 0           my $line = strftime( $self->{id}->line_timestamp_fmt, localtime $time );
337 0 0         $line .= " ".$ctx->path_residue if length $ctx->path_residue;
338 0           $line .= " $event";
339 0           $line .= " ".$self->encode( $args );
340 0           $line .= "\n";
341              
342 0           $self->{fh}->print( $line );
343             }
344              
345             ## This should output a valid YAML encoding of a data tree, on a single line
346             # using flow-style mappings and sequences
347             # Similar to JSON except without quoted keys
348              
349             sub encode
350             {
351 0     0     my $self = shift;
352 0           my ( $args ) = @_;
353              
354 0 0         if( !ref $args ) {
    0          
    0          
355 0           my $str = "$args";
356 0           $str =~ s/(["\\])/\\$1/g;
357 0           $str =~ s/\n/\\n/g;
358 0           $str =~ s/\t/\\t/g;
359 0           $str =~ s/([\x00-\x1f\x80-\x9f])/sprintf "\\x%02x", ord $1/eg;
  0            
360 0           return qq("$str");
361             }
362             elsif( ref $args eq "HASH" ) {
363             return "{" . join( ", ", map {
364 0           "$_: ".$self->encode( $args->{$_} )
  0            
365             } sort keys %$args ) . "}";
366             }
367             elsif( ref $args eq "ARRAY" ) {
368             return "[" . join( ", ", map {
369 0           $self->encode( $args->[$_] )
  0            
370             } 0 .. $#$args ) . "]";
371             }
372             else {
373 0           return "$args";
374             }
375             }
376              
377             0x55AA;