File Coverage

blib/lib/Log/Agent/Channel/Handle.pm
Criterion Covered Total %
statement 32 35 91.4
branch 6 12 50.0
condition n/a
subroutine 6 7 85.7
pod 4 4 100.0
total 48 58 82.7


line stmt bran cond sub pod time code
1             ###########################################################################
2             #
3             # Handle.pm
4             #
5             # Copyright (C) 1999 Raphael Manfredi.
6             # Copyright (C) 2002-2017 Mark Rogaski, mrogaski@cpan.org;
7             # all rights reserved.
8             #
9             # See the README file included with the
10             # distribution for license information.
11             #
12             ##########################################################################
13            
14 1     1   7 use strict;
  1         2  
  1         72  
15             require Log::Agent::Channel;
16             require Log::Agent::Prefixer;
17             require Log::Agent::File::Native;
18            
19             ########################################################################
20             package Log::Agent::Channel::Handle;
21            
22 1     1   8 use vars qw(@ISA);
  1         2  
  1         102  
23            
24             @ISA = qw(Log::Agent::Channel Log::Agent::Prefixer);
25            
26 1     1   540 use Log::Agent::Stamping;
  1         3  
  1         475  
27            
28             #
29             # ->make -- defined
30             #
31             # Creation routine.
32             #
33             # Attributes (and switches that set them):
34             #
35             # prefix the application name
36             # stampfmt stamping format ("syslog", "date", "own", "none") or closure
37             # showpid whether to show pid after prefix in []
38             # handle I/O glob or IO::Handle object
39             # no_ucfirst don't capitalize first letter of message when no prefix
40             # no_prefixing don't prefix logs
41             # no_newline never append any newline character at the end of messages
42             #
43             # Other attributes:
44             #
45             # crlf the new-line marker for this OS ("\n" on UNIX)
46             #
47             sub make {
48 2     2 1 6 my $self = bless {}, shift;
49 2         10 my (%args) = @_;
50            
51             my %set = (
52             -prefix => \$self->{'prefix'},
53             -stampfmt => \$self->{'stampfmt'},
54             -showpid => \$self->{'showpid'},
55             -handle => \$self->{'handle'},
56             -no_ucfirst => \$self->{'no_ucfirst'},
57             -no_prefixing => \$self->{'no_prefixing'},
58 2         19 -no_newline => \$self->{'no_newline'},
59             );
60            
61 2         9 while (my ($arg, $val) = each %args) {
62 8         15 my $vset = $set{lc($arg)};
63 8 50       17 unless (ref $vset) {
64 0         0 require Carp;
65 0         0 Carp::croak("Unknown switch $arg");
66             }
67 8         22 $$vset = $val;
68             }
69            
70             #
71             # Initialize proper time-stamping routine.
72             #
73            
74 2 50       10 $self->{'stampfmt'} = stamping_fn($self->stampfmt)
75             unless ref $self->stampfmt eq 'CODE';
76            
77 2 50       15 $self->{'crlf'} = $^O =~ /^dos|win/i ? "\r\n" : "\n";
78            
79 2         10 return $self;
80             }
81            
82             #
83             # Local attribute access
84             #
85            
86 0     0 1 0 sub handle { $_[0]->{'handle'} }
87            
88             #
89             # ->write -- defined
90             #
91             # Write logstring to the file.
92             # Priority is ignored by this channel.
93             #
94             sub write {
95 2     2 1 3 my $self = shift;
96 2         5 my ($priority, $logstring) = @_;
97            
98             #
99             # This routine is called often...
100             # Bypass the attribute access routines.
101             #
102            
103 2         5 my $handle = $self->{handle};
104 2 50       4 return unless defined $handle;
105            
106 2         4 my $prefix = '';
107             $prefix = $self->prefixing_string(\$logstring)
108 2 50       10 unless $self->{no_prefixing};
109            
110 2         4 my $crlf = '';
111 2 50       8 $crlf = $self->{crlf} unless $self->{no_newline};
112            
113 2         81 print $handle join '', $prefix, $logstring, $crlf;
114            
115 2         14 return;
116             }
117            
118             #
119             # ->close -- defined
120             #
121             #
122             sub close {
123 2     2 1 3 my $self = shift;
124 2         3 $self->{handle} = undef;
125            
126             #
127             # Do nothing on the handle itself.
128             # We did not open the thing, we don't get to close it.
129             #
130            
131 2         16 return;
132             }
133            
134             1; # for require
135             __END__