File Coverage

blib/lib/Log/Handler/Output/Forward.pm
Criterion Covered Total %
statement 42 51 82.3
branch 7 12 58.3
condition 2 3 66.6
subroutine 9 11 81.8
pod 5 5 100.0
total 65 82 79.2


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Log::Handler::Output::Forward - Forward messages to routines.
4              
5             =head1 SYNOPSIS
6              
7             use Log::Handler::Output::Forward;
8              
9             my $forwarder = Log::Handler::Output::Forward->new(
10             forward_to => sub { },
11             arguments => [ "foo" ],
12             );
13              
14             $forwarder->log(message => $message);
15              
16             =head1 DESCRIPTION
17              
18             This output module makes it possible to forward messages to sub routines.
19              
20             =head1 METHODS
21              
22             =head2 new()
23              
24             Call C to create a new Log::Handler::Output::Forward object.
25              
26             The following options are possible:
27              
28             =over 4
29              
30             =item B
31              
32             This option excepts a code reference.
33              
34             Please note that the message is forwarded as a hash reference. If you change it
35             then this would have an effect to all outputs.
36              
37             =item B
38              
39             With this option you can define arguments that will be passed to the sub
40             routine.
41              
42             In the following example the arguments would be passed as a array to
43             C.
44              
45             my $forwarder = Log::Handler::Output::Forward->new(
46             forward_to => \&Class::method,
47             arguments => [ $self, "foo" ],
48             );
49              
50             This would call intern:
51              
52             Class::method(@arguments, $message);
53              
54             If this option is not set then the message will be passed as first argument.
55              
56             =back
57              
58             =head2 log()
59              
60             Call C if you want to forward messages to the subroutines.
61              
62             Example:
63              
64             $forwarder->log("this message will be forwarded to all sub routines");
65              
66             =head2 validate()
67              
68             Validate a configuration.
69              
70             =head2 reload()
71              
72             Reload with a new configuration.
73              
74             =head2 errstr()
75              
76             This function returns the last error message.
77              
78             =head1 FORWARDED MESSAGE
79              
80             Note that the message will be forwarded as a hash reference.
81              
82             If you make changes to the reference it affects all other outputs.
83              
84             The hash key C contains the message.
85              
86             =head1 PREREQUISITES
87              
88             Carp
89             Params::Validate
90              
91             =head1 EXPORTS
92              
93             No exports.
94              
95             =head1 REPORT BUGS
96              
97             Please report all bugs to .
98              
99             If you send me a mail then add Log::Handler into the subject.
100              
101             =head1 AUTHOR
102              
103             Jonny Schulz .
104              
105             =head1 COPYRIGHT
106              
107             Copyright (C) 2007-2009 by Jonny Schulz. All rights reserved.
108              
109             This program is free software; you can redistribute it and/or
110             modify it under the same terms as Perl itself.
111              
112             =cut
113              
114             package Log::Handler::Output::Forward;
115              
116 12     12   71 use strict;
  12         31  
  12         390  
117 12     12   47 use warnings;
  12         16  
  12         351  
118 12     12   42 use Carp;
  12         14  
  12         873  
119 12     12   45 use Params::Validate qw();
  12         13  
  12         5101  
120              
121             our $VERSION = "0.03";
122             our $ERRSTR = "";
123              
124             sub new {
125 28     28 1 30 my $class = shift;
126 28         58 my $options = $class->_validate(@_);
127 28         140 return bless $options, $class;
128             }
129              
130             sub log {
131 60     60 1 60 my $self = shift;
132 60         55 my $coderef = $self->{forward_to};
133 60 50       97 my $message = @_ > 1 ? {@_} : shift;
134              
135 60 100       84 if ($self->{arguments}) {
136 13         12 eval { &$coderef(@{$self->{arguments}}, $message) };
  13         9  
  13         29  
137             } else {
138 47         47 eval { &$coderef($message) };
  47         90  
139             }
140              
141 60 50       3104 if ($@) {
142 0         0 return $self->_raise_error($@);
143             }
144              
145 60         138 return 1;
146             }
147              
148             sub validate {
149 9     9 1 11 my $self = shift;
150 9         5 my $opts = ();
151              
152 9         9 eval { $opts = $self->_validate(@_) };
  9         23  
153              
154 9 50       16 if ($@) {
155 0         0 $ERRSTR = $@;
156 0         0 return undef;
157             }
158              
159 9         24 return $opts;
160             }
161              
162             sub reload {
163 3     3 1 4 my $self = shift;
164 3         5 my $opts = $self->validate(@_);
165              
166 3 50       8 if (!$opts) {
167 0         0 return undef;
168             }
169              
170 3         6 foreach my $key (keys %$opts) {
171 3         5 $self->{$key} = $opts->{$key};
172             }
173              
174 3         12 return 1;
175             }
176              
177             sub errstr {
178 0     0 1 0 return $ERRSTR;
179             }
180              
181             #
182             # private stuff
183             #
184              
185             sub _validate {
186 37     37   32 my $class = shift;
187              
188 37         513 my %options = Params::Validate::validate(@_, {
189             forward_to => {
190             type => Params::Validate::CODEREF,
191             },
192             arguments => {
193             type => Params::Validate::ARRAYREF
194             | Params::Validate::SCALAR,
195             optional => 1,
196             },
197             });
198              
199 37 50 66     176 if (defined $options{arguments} && !ref($options{arguments})) {
200 0         0 $options{arguments} = [ $options{arguments} ];
201             }
202              
203 37         70 return \%options;
204             }
205              
206             sub _raise_error {
207 0     0     my $self = shift;
208 0           $ERRSTR = shift;
209 0           return undef;
210             }
211              
212             1;