← Index
NYTProf Performance Profile   « block view • line view • sub view »
For mentat.storage.mongo.pl
  Run on Tue Jun 24 10:04:38 2014
Reported on Tue Jun 24 10:05:08 2014

Filename/usr/local/lib/site_perl/Log/Writer/Handle.pm
StatementsExecuted 35 statements in 1.44ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111610µs982µsLog::Writer::Handle::::BEGIN@121Log::Writer::Handle::BEGIN@121
11117µs20µsLog::Writer::Handle::::BEGIN@2Log::Writer::Handle::BEGIN@2
11111µs11µsLog::Writer::Handle::::BEGIN@124Log::Writer::Handle::BEGIN@124
1119µs51µsLog::Writer::Handle::::BEGIN@110Log::Writer::Handle::BEGIN@110
1119µs41µsLog::Writer::Handle::::BEGIN@111Log::Writer::Handle::BEGIN@111
1118µs41µsLog::Writer::Handle::::BEGIN@143Log::Writer::Handle::BEGIN@143
1118µs43µsLog::Writer::Handle::::BEGIN@108Log::Writer::Handle::BEGIN@108
1117µs13µsLog::Writer::Handle::::BEGIN@3Log::Writer::Handle::BEGIN@3
1117µs47µsLog::Writer::Handle::::BEGIN@125Log::Writer::Handle::BEGIN@125
1117µs26µsLog::Writer::Handle::::BEGIN@112Log::Writer::Handle::BEGIN@112
1117µs29µsLog::Writer::Handle::::BEGIN@109Log::Writer::Handle::BEGIN@109
1116µs33µsLog::Writer::Handle::::BEGIN@145Log::Writer::Handle::BEGIN@145
1116µs31µsLog::Writer::Handle::::BEGIN@148Log::Writer::Handle::BEGIN@148
1116µs32µsLog::Writer::Handle::::BEGIN@144Log::Writer::Handle::BEGIN@144
1116µs31µsLog::Writer::Handle::::BEGIN@146Log::Writer::Handle::BEGIN@146
1114µs4µsLog::Writer::Handle::::BEGIN@120Log::Writer::Handle::BEGIN@120
1112µs2µsLog::Writer::Handle::::ENDLog::Writer::Handle::END
0000s0sLog::Writer::Handle::::_format_messageLog::Writer::Handle::_format_message
0000s0sLog::Writer::Handle::::_get_possible_flagsLog::Writer::Handle::_get_possible_flags
0000s0sLog::Writer::Handle::::_initLog::Writer::Handle::_init
0000s0sLog::Writer::Handle::::_lockLog::Writer::Handle::_lock
0000s0sLog::Writer::Handle::::_setup_date_formatLog::Writer::Handle::_setup_date_format
0000s0sLog::Writer::Handle::::_setup_handleLog::Writer::Handle::_setup_handle
0000s0sLog::Writer::Handle::::_unlockLog::Writer::Handle::_unlock
0000s0sLog::Writer::Handle::::handle_forkLog::Writer::Handle::handle_fork
0000s0sLog::Writer::Handle::::writeLog::Writer::Handle::write
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Log::Writer::Handle;
2224µs223µs
# spent 20µs (17+3) within Log::Writer::Handle::BEGIN@2 which was called: # once (17µs+3µs) by Log::Loger::BEGIN@130 at line 2
use strict;
# spent 20µs making 1 call to Log::Writer::Handle::BEGIN@2 # spent 3µs making 1 call to strict::import
3273µs218µs
# spent 13µs (7+5) within Log::Writer::Handle::BEGIN@3 which was called: # once (7µs+5µs) by Log::Loger::BEGIN@130 at line 3
use warnings;
# spent 13µs making 1 call to Log::Writer::Handle::BEGIN@3 # spent 6µs making 1 call to warnings::import
4
5#*******************************************************************************
6#
7# DOCUMENTATION SECTION
8#
9#*******************************************************************************
10
11=head1 NAME
12
13Log::Writer::Handle - Log writer capable of writing to any filehandle
14
15=head1 SYNOPSIS
16
17 use Log::Writer::Handle;
18
19 # Prepare some IO capable objects (handles)
20 my $buffer = '';
21 my $handle = IO::Handle->new_from_fd(fileno(STDERR),"w") or die "Can't open 'STDERR': $!\n";
22 my $handle = IO::File->new('./spool/writer-handle.log','>') or die "Can't open file './spool/test.log': $!\n";
23 my $handle = IO::String->new($buffer) or die "Can't open string buffer: $!\n";
24
25 # Various methods of writer instantination
26 my $writer = Log::Writer::Handle->new($handle);
27 my $writer = Log::Writer::Handle->new($handle, 'iso8601');
28 my $writer = Log::Writer::Handle->new($handle, '%FT%T%z');
29 my $writer = Log::Writer::Handle->new($handle, undef, 'r');
30 my $writer = Log::Writer::Handle->new($handle, undef, 'rep');
31 my $writer = Log::Writer::Handle->new($handle, undef, 'replace');
32 my $writer = Log::Writer::Handle->new($handle, undef, 's', './spool/writer-handle.lock');
33 my $writer = Log::Writer::Handle->new($handle, undef, 'ser', './spool/writer-handle.lock');
34 my $writer = Log::Writer::Handle->new($handle, undef, 'serialize', './spool/writer-handle.lock');
35 my $writer = Log::Writer::Handle->new($handle, undef, 'r,s', './spool/writer-handle.lock');
36 my $writer = Log::Writer::Handle->new($handle, undef, 'rep,ser', './spool/writer-handle.lock');
37 my $writer = Log::Writer::Handle->new($handle, undef, 'replace,serialize', './spool/writer-handle.lock');
38
39 # Write the message into the writer
40 $writer->write('module', 'severity', 'Message from Log::Writer::Handle');
41
42 # Process safe writing - if the fork occurs after log writer initialization, lock must be reopened
43 my $writer = new Log::Writer::Handle($hnd, undef, 'rep ser', './spool/test.lock');
44 die "fork: $!" unless defined (my $pid = fork);
45 $writer->handle_fork();
46 my $identity = '[CHILD] ';
47 if ($pid) { $identity = '[PARENT]'; }
48 $writer->write('module', 'severity', '$identity: Message from Log::Writer::Handle');
49 if ($pid) { wait; }
50
51=head1 DESCRIPTION
52
53This writer writes given messages to the given IO::Handle.
54
55=head1 FLAGS
56
57=over
58
59=item B<c|com|comment>
60
61 COMMENT out every line with '#' character
62
63=item B<r|rep|replace>
64
65 REPLACE source name given to the write() method with program name
66
67=item B<s|ser|serialize>
68
69 SERIALIZE the write operations using mutual exclusion lock
70
71=item B<t|tra|traceback>
72
73 TRACEBACK
74
75=head1 AUTHOR
76
77Jan Mach
78Cesnet, z.s.p.o
79jan.mach@cesnet.cz
80http://www.cesnet.cz
81
82=head1 COPYRIGHT
83
84This program is free software; you can redistribute
85it and/or modify it under the same terms as Perl itself.
86
87The full text of the license can be found in the
88LICENSE file included with this module.
89
90
91=head1 SEE ALSO
92
93perl(1), Log::Core::Essentials(3).
94
95=head1 FUNCTION REFERENCE
96
97=over 4
98
99=cut
100
101#*******************************************************************************
102#
103# INITIALIZATION AND CLEANUP SECTION
104#
105#*******************************************************************************
106
107#-- Perl core modules ---------------------------------------------------------#
108225µs279µs
# spent 43µs (8+35) within Log::Writer::Handle::BEGIN@108 which was called: # once (8µs+35µs) by Log::Loger::BEGIN@130 at line 108
use Carp;
# spent 43µs making 1 call to Log::Writer::Handle::BEGIN@108 # spent 35µs making 1 call to Exporter::import
109224µs251µs
# spent 29µs (7+22) within Log::Writer::Handle::BEGIN@109 which was called: # once (7µs+22µs) by Log::Loger::BEGIN@130 at line 109
use Scalar::Util 'blessed';
# spent 29µs making 1 call to Log::Writer::Handle::BEGIN@109 # spent 22µs making 1 call to Exporter::import
110230µs293µs
# spent 51µs (9+42) within Log::Writer::Handle::BEGIN@110 which was called: # once (9µs+42µs) by Log::Loger::BEGIN@130 at line 110
use POSIX qw(strftime);
# spent 51µs making 1 call to Log::Writer::Handle::BEGIN@110 # spent 42µs making 1 call to POSIX::import
111223µs273µs
# spent 41µs (9+32) within Log::Writer::Handle::BEGIN@111 which was called: # once (9µs+32µs) by Log::Loger::BEGIN@130 at line 111
use File::Basename;
# spent 41µs making 1 call to Log::Writer::Handle::BEGIN@111 # spent 32µs making 1 call to Exporter::import
112232µs245µs
# spent 26µs (7+19) within Log::Writer::Handle::BEGIN@112 which was called: # once (7µs+19µs) by Log::Loger::BEGIN@130 at line 112
use Sys::Hostname;
# spent 26µs making 1 call to Log::Writer::Handle::BEGIN@112 # spent 19µs making 1 call to Exporter::import
113
114#use Data::Dumper; #-+-> DEVEL ONLY <-+-#
115#use Smart::Comments; #-+-> DEVEL ONLY <-+-#
116
117#-- Perl CPAN modules ---------------------------------------------------------#
118
119#-- Custom application modules ------------------------------------------------#
120220µs14µs
# spent 4µs within Log::Writer::Handle::BEGIN@120 which was called: # once (4µs+0s) by Log::Loger::BEGIN@130 at line 120
use Log::Writer::Module;
# spent 4µs making 1 call to Log::Writer::Handle::BEGIN@120
1212131µs1982µs
# spent 982µs (610+371) within Log::Writer::Handle::BEGIN@121 which was called: # once (610µs+371µs) by Log::Loger::BEGIN@130 at line 121
use Mutex::Flock;
# spent 982µs making 1 call to Log::Writer::Handle::BEGIN@121
122
123#-- Module initializations ----------------------------------------------------#
124
# spent 11µs within Log::Writer::Handle::BEGIN@124 which was called: # once (11µs+0s) by Log::Loger::BEGIN@130 at line 129
BEGIN {
125243µs286µs
# spent 47µs (7+39) within Log::Writer::Handle::BEGIN@125 which was called: # once (7µs+39µs) by Log::Loger::BEGIN@130 at line 125
use vars qw($VERSION $DEVEL @ISA);
# spent 47µs making 1 call to Log::Writer::Handle::BEGIN@125 # spent 39µs making 1 call to vars::import
12639µs $VERSION = '0.01';
127 $DEVEL = 0;
128 @ISA = ('Log::Writer::Module');
129139µs111µs}
# spent 11µs making 1 call to Log::Writer::Handle::BEGIN@124
130
131#-- Module clean-up code (global destructor) ----------------------------------#
13212µs
# spent 2µs within Log::Writer::Handle::END which was called: # once (2µs+0s) by main::RUNTIME at line 0 of mentat.storage.mongo.pl
END {
133
134}
135
136#*******************************************************************************
137#
138# CONSTANTS AND GLOBAL VARIABLES DEFINITION SECTION
139#
140#*******************************************************************************
141
142#-- Constants -----------------------------------------------------------------#
143227µs273µs
# spent 41µs (8+32) within Log::Writer::Handle::BEGIN@143 which was called: # once (8µs+32µs) by Log::Loger::BEGIN@130 at line 143
use constant FLAG_COMMENT => 'COMMENT';
# spent 41µs making 1 call to Log::Writer::Handle::BEGIN@143 # spent 32µs making 1 call to constant::import
144226µs259µs
# spent 32µs (6+26) within Log::Writer::Handle::BEGIN@144 which was called: # once (6µs+26µs) by Log::Loger::BEGIN@130 at line 144
use constant FLAG_REPLACE => 'REPLACE';
# spent 32µs making 1 call to Log::Writer::Handle::BEGIN@144 # spent 26µs making 1 call to constant::import
145224µs260µs
# spent 33µs (6+27) within Log::Writer::Handle::BEGIN@145 which was called: # once (6µs+27µs) by Log::Loger::BEGIN@130 at line 145
use constant FLAG_SERIALIZE => 'SERIALIZE';
# spent 33µs making 1 call to Log::Writer::Handle::BEGIN@145 # spent 27µs making 1 call to constant::import
146224µs257µs
# spent 31µs (6+25) within Log::Writer::Handle::BEGIN@146 which was called: # once (6µs+25µs) by Log::Loger::BEGIN@130 at line 146
use constant FLAG_TRACEBACK => 'TRACEBACK';
# spent 31µs making 1 call to Log::Writer::Handle::BEGIN@146 # spent 25µs making 1 call to constant::import
147
1482857µs256µs
# spent 31µs (6+25) within Log::Writer::Handle::BEGIN@148 which was called: # once (6µs+25µs) by Log::Loger::BEGIN@130 at line 148
use constant ISO8601 => 'ISO8601';
# spent 31µs making 1 call to Log::Writer::Handle::BEGIN@148 # spent 25µs making 1 call to constant::import
149
150#-- Static public class variables (our) ---------------------------------------#
151
152#-- Static protected class variables (my) -------------------------------------#
153
154#*******************************************************************************
155#
156# IMPLEMENTATION SECTION
157#
158#*******************************************************************************
159
160=item write($$$) [PUBLIC]
161
162 Usage : $writer->write($source, $severity, $message);
163 Purpose : Write given message to the destination
164 Arguments : STRING $source - Name of the source of the message
165 ENUM $severity - Severity in integer or string format (see Log::Core::Essentials for permited values)
166 STRING $message - Log message
167 Returns : $self
168 Throws : Dies, if not implemented in descendant classes
169 Comments : ABSTRACT method, must be implemented in descendant classes
170 See Also : Log::Core::Essentials module for permited severity values
171
172=cut
173
174sub write($$$)
175{
176 my $self = shift;
177 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
178 my ($source, $severity, $message) = @_;
179 croak ((caller(0))[3] . ": received invalid arguments") unless (defined($source) and defined($severity) and defined($message));
180
181 #
182 $self->_lock();
183 print { $self->{IO_HANDLE} } $self->_format_message($source, $severity, $message) or die ("Error writing message: $!");
184 $self->_unlock();
185
186 return $self;
187}
188
189=item handle_fork() [PUBLIC]
190
191 Usage : $writer->handle_fork();
192 Purpose : Allow writer to react to the fork() (sometimes it is necessary to reopen
193 file descriptors etc.)
194 Arguments : None
195 Returns : $self
196 Throws : Dies, if not implemented in descendant classes
197 Comments : ABSTRACT method, must be implemented in descendant classes
198
199=cut
200
201sub handle_fork()
202{
203 my $self = shift;
204 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
205
206 $self->{LOCK}->reopen();
207 return $self;
208}
209
210#-------------------------------------------------------------------------------
211# Private interface
212#-------------------------------------------------------------------------------
213
214# _init [PROTECTED]
215#
216# Usage : return $self->_init(@_);
217# Purpose : Initialize the new Log::Writer::Handle instance
218# Arguments : IO::Handle $handle - handle to write to
219# STRING $date_format - date format (see. man strftime(3) for details on syntax) [MANDATORY]
220# STRING $flags - various processing flags [OPTIONAL]
221# s | ser | serialize - serialize the writes (for multiprocess application)
222# r | rep | replace - replace source of the message with the program name
223# STRING $lock_file - name of the lock file [MANDATORY if 'serialize' flag is set]
224# Returns : Log::Writer::Module reference
225# Throws : Dies, if invoked on class
226# Comments : This method must never be called directly, it is supposed to be overloaded by subclasses
227
228sub _init
229{
230 my $self = shift;
231 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
232 my ($handle, $date_format, $flags, $lock_file) = @_;
233 croak ((caller(0))[3] . ": IO handle must be given as first argument") unless (defined($handle));
234
235 $self->_setup_handle($handle);
236 $self->_setup_date_format($date_format);
237 $self->_setup_flags($flags);
238
239 if ($self->_flag(FLAG_SERIALIZE())) {
240 croak ((caller(0))[3] . ": missing arguments - lock file") unless (defined($lock_file));
241 $self->{LOCK} = Mutex::Flock->new($lock_file);
242 }
243 return $self;
244}
245
246# _get_possible_flags() [PROTECTED]
247#
248# Usage : my $flags = $self->_get_possible_flags();
249# Purpose : Get hash structure describing all possible flags
250# Arguments : None
251# Returns : HASH REFERENCE $flags
252# Throws : Dies, if invoked on class
253
254sub _get_possible_flags()
255{
256 my $self = shift;
257 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
258
259 return {
260 'c' => FLAG_COMMENT(),
261 'com' => FLAG_COMMENT(),
262 'comment' => FLAG_COMMENT(),
263 'r' => FLAG_REPLACE(),
264 'rep' => FLAG_REPLACE(),
265 'replace' => FLAG_REPLACE(),
266 's' => FLAG_SERIALIZE(),
267 'ser' => FLAG_SERIALIZE(),
268 'serialize' => FLAG_SERIALIZE(),
269 't' => FLAG_TRACEBACK(),
270 'tra' => FLAG_TRACEBACK(),
271 'traceback' => FLAG_TRACEBACK(),
272 };
273}
274
275# _setup_handle($) [PROTECTED]
276#
277# Usage : $self->_setup_handle($handle);
278# Purpose : Set IO::Handle to write messages to
279# Arguments : IO::Handle $handle - handle to write to
280# Returns : $self
281# Throws : Dies, if invoked on class, or if given invalid arguments
282
283sub _setup_handle($)
284{
285 my $self = shift;
286 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
287 my ($handle,) = @_;
288 croak ((caller(0))[3] . ": given handle is not capable of 'print'") unless ($handle->can("print"));
289
290 $self->{IO_HANDLE} = $handle;
291 return $self;
292}
293
294# _setup_date_format($) [PROTECTED]
295#
296# Usage : $self->_setup_date_format($date_format);
297# Purpose : Set format according to which to display the date
298# Arguments : STRING $date_format - date format (see. strftime() for details on syntax)
299# Returns : $self
300# Throws : Dies, if invoked on class
301
302sub _setup_date_format($)
303{
304 my $self = shift;
305 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
306 my ($date_format,) = @_;
307
308 $self->{DATE_FORMAT} = $date_format;
309 $self->{DATE_FORMAT} = '%FT%T%z' if $date_format and uc($date_format) eq ISO8601;
310 return $self;
311}
312
313# _format_message($$$) [PROTECTED]
314#
315# Usage : my $message = $self->_format_message($source, $severity, $message)
316# Purpose : Format log message from the given source, severity and message body
317# Arguments : STRING $source - Name of the source of the message
318# ENUM $severity - Severity in integer or string format (see Log::Core::Essentials for permited values)
319# STRING $message - Message
320# Returns : STRING formatted message
321# Throws : Dies, if invoked on class
322
323sub _format_message($$$)
324{
325 my $self = shift;
326 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
327 my ($source, $severity, $message) = @_;
328
329 my $date = localtime;
330 my $hostname = hostname;
331 my $cmnt = ($self->_flag(FLAG_COMMENT()))?'# ':'';
332 $source = basename($0) if ($self->_flag(FLAG_REPLACE()));
333 $date = strftime($self->{DATE_FORMAT}, localtime) if ($self->{DATE_FORMAT});
334 $message =~ s/\n(.+)/\n# $1/g if ($self->_flag(FLAG_COMMENT()));
335
336 return "$cmnt$date $hostname ${source}[$$]: $severity: $message\n" unless $self->_flag(FLAG_TRACEBACK());
337 return "$cmnt$date $hostname ${source}[$$]: $severity: $message\n$cmnt Backtrace:\n$cmnt * " . join("\n$cmnt * ", $self->_traceback()) . "\n";
338 #return "$cmnt$date $hostname ${source}[$$]: $severity: $message\n$cmnt Backtrace:\n$cmnt * " . join("\n$cmnt * ", $self->_backtrace()) . "\n";
339}
340
341# _lock() [PROTECTED]
342#
343# Usage : $self->_lock();
344# Purpose : Lock the lock file for serialization before writing
345# Arguments : None
346# Returns : $self
347# Throws : Dies, if invoked on class
348
349sub _lock() {
350 my $self = shift;
351 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
352
353 $self->{LOCK}->lock() if $self->_flag(FLAG_SERIALIZE());
354 return $self;
355}
356
357# _unlock() [PROTECTED]
358#
359# Usage : $self->_unlock();
360# Purpose : Unlock the lock file for serialization after writing
361# Arguments : None
362# Returns : $self
363# Throws : Dies, if invoked on class
364
365sub _unlock() {
366 my $self = shift;
367 croak ((caller(0))[3] . ": instance method invoked on class") unless blessed($self);
368
369 $self->{LOCK}->unlock() if $self->_flag(FLAG_SERIALIZE());
370 return $self;
371}
372
373=pod
374
375=back
376
377=cut
378
37912µs1;