Commit | Line | Data |
ae59bbe3 |
1 | package Log::Contextual::WarnLogger; |
2 | |
dc4fd4b0 |
3 | # ABSTRACT: logger for libraries using Log::Contextual |
4 | |
ae59bbe3 |
5 | use strict; |
6 | use warnings; |
7 | |
e7b18282 |
8 | use Carp 'croak'; |
9 | |
10 | my @default_levels = qw( trace debug info warn error fatal ); |
11 | |
e7b18282 |
12 | # generate subs to handle the default levels |
13 | # anything else will have to be handled by AUTOLOAD at runtime |
ae59bbe3 |
14 | { |
6ae293d7 |
15 | for my $level (@default_levels) { |
ae59bbe3 |
16 | |
6ae293d7 |
17 | no strict 'refs'; |
ae59bbe3 |
18 | |
6ae293d7 |
19 | my $is_name = "is_$level"; |
20 | *{$level} = sub { |
21 | my $self = shift; |
ae59bbe3 |
22 | |
6ae293d7 |
23 | $self->_log($level, @_) |
24 | if $self->$is_name; |
25 | }; |
ae59bbe3 |
26 | |
6ae293d7 |
27 | *{$is_name} = sub { |
28 | my $self = shift; |
29 | return 1 if $ENV{$self->{env_prefix} . '_' . uc $level}; |
30 | my $upto = $ENV{$self->{env_prefix} . '_UPTO'}; |
31 | return unless $upto; |
32 | $upto = lc $upto; |
33 | |
34 | return $self->{level_num}{$level} >= $self->{level_num}{$upto}; |
35 | }; |
36 | } |
ae59bbe3 |
37 | } |
38 | |
e7b18282 |
39 | our $AUTOLOAD; |
6ae293d7 |
40 | |
e7b18282 |
41 | sub AUTOLOAD { |
6ae293d7 |
42 | my $self = $_[0]; |
e7b18282 |
43 | |
6ae293d7 |
44 | (my $name = our $AUTOLOAD) =~ s/.*:://; |
45 | return if $name eq 'DESTROY'; |
e7b18282 |
46 | |
6ae293d7 |
47 | # extract the log level from the sub name |
48 | my ($is, $level) = $name =~ m/^(is_)?(.+)$/; |
49 | my $is_name = "is_$level"; |
e7b18282 |
50 | |
6ae293d7 |
51 | no strict 'refs'; |
52 | *{$level} = sub { |
53 | my $self = shift; |
e7b18282 |
54 | |
6ae293d7 |
55 | $self->_log($level, @_) |
56 | if $self->$is_name; |
57 | }; |
e7b18282 |
58 | |
6ae293d7 |
59 | *{$is_name} = sub { |
60 | my $self = shift; |
e7b18282 |
61 | |
6ae293d7 |
62 | my $prefix_field = $self->{env_prefix} . '_' . uc $level; |
63 | return 1 if $ENV{$prefix_field}; |
e7b18282 |
64 | |
6ae293d7 |
65 | # don't log if the variable specifically says not to |
66 | return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field}; |
e7b18282 |
67 | |
6ae293d7 |
68 | my $upto_field = $self->{env_prefix} . '_UPTO'; |
69 | my $upto = $ENV{$upto_field}; |
e7b18282 |
70 | |
6ae293d7 |
71 | if ($upto) { |
72 | $upto = lc $upto; |
e7b18282 |
73 | |
6ae293d7 |
74 | croak "Unrecognized log level '$upto' in \$ENV{$upto_field}" |
75 | if not defined $self->{level_num}{$upto}; |
e7b18282 |
76 | |
6ae293d7 |
77 | return $self->{level_num}{$level} >= $self->{level_num}{$upto}; |
78 | } |
e7b18282 |
79 | |
6ae293d7 |
80 | # if we don't recognize this level and nothing says otherwise, log! |
81 | return 1 if not $self->{custom_levels}; |
82 | }; |
83 | goto &$AUTOLOAD; |
e7b18282 |
84 | } |
85 | |
ae59bbe3 |
86 | sub new { |
6ae293d7 |
87 | my ($class, $args) = @_; |
e7b18282 |
88 | |
6ae293d7 |
89 | my $levels = $args->{levels}; |
90 | croak 'invalid levels specification: must be non-empty arrayref' |
91 | if defined $levels and (ref $levels ne 'ARRAY' or !@$levels); |
e7b18282 |
92 | |
6ae293d7 |
93 | my $custom_levels = defined $levels; |
94 | $levels ||= [@default_levels]; |
e7b18282 |
95 | |
6ae293d7 |
96 | my %level_num; |
97 | @level_num{@$levels} = (0 .. $#{$levels}); |
e7b18282 |
98 | |
6ae293d7 |
99 | my $self = bless { |
100 | levels => $levels, |
101 | level_num => \%level_num, |
102 | custom_levels => $custom_levels, |
103 | }, $class; |
ae59bbe3 |
104 | |
6ae293d7 |
105 | $self->{env_prefix} = $args->{env_prefix} |
106 | or die 'no env_prefix passed to Log::Contextual::WarnLogger->new'; |
107 | return $self; |
ae59bbe3 |
108 | } |
109 | |
110 | sub _log { |
6ae293d7 |
111 | my $self = shift; |
112 | my $level = shift; |
113 | my $message = join("\n", @_); |
114 | $message .= "\n" unless $message =~ /\n$/; |
115 | warn "[$level] $message"; |
ae59bbe3 |
116 | } |
117 | |
118 | 1; |
119 | |
120 | __END__ |
121 | |
ae59bbe3 |
122 | =head1 SYNOPSIS |
123 | |
124 | package My::Package; |
125 | use Log::Contextual::WarnLogger; |
126 | use Log::Contextual qw( :log ), |
127 | -default_logger => Log::Contextual::WarnLogger->new({ |
e7b18282 |
128 | env_prefix => 'MY_PACKAGE', |
129 | levels => [ qw(debug info notice warning error critical alert emergency) ], |
ae59bbe3 |
130 | }); |
131 | |
132 | # warns '[info] program started' if $ENV{MY_PACKAGE_TRACE} is set |
133 | log_info { 'program started' }; # no-op because info is not in levels |
134 | sub foo { |
135 | # warns '[debug] entered foo' if $ENV{MY_PACKAGE_DEBUG} is set |
136 | log_debug { 'entered foo' }; |
137 | ... |
138 | } |
139 | |
e7b18282 |
140 | |
141 | |
ae59bbe3 |
142 | =head1 DESCRIPTION |
143 | |
144 | This module is a simple logger made for libraries using L<Log::Contextual>. We |
145 | recommend the use of this logger as your default logger as it is simple and |
146 | useful for most users, yet users can use L<Log::Contextual/set_logger> to override |
147 | your choice of logger in their own code thanks to the way L<Log::Contextual> |
148 | works. |
149 | |
150 | =head1 METHODS |
151 | |
152 | =head2 new |
153 | |
e7b18282 |
154 | Arguments: C<< Dict[ env_prefix => Str, levels => List ] $conf >> |
ae59bbe3 |
155 | |
54714ae9 |
156 | my $l = Log::Contextual::WarnLogger->new({ env_prefix => 'BAR' }); |
e7b18282 |
157 | |
158 | or: |
159 | |
160 | my $l = Log::Contextual::WarnLogger->new({ |
161 | env_prefix => 'BAR', |
54714ae9 |
162 | levels => [ 'level1', 'level2' ], |
ae59bbe3 |
163 | }); |
164 | |
165 | Creates a new logger object where C<env_prefix> defines what the prefix is for |
e7b18282 |
166 | the environment variables that will be checked for the log levels. |
167 | |
168 | The log levels may be customized, but if not defined, these are used: |
169 | |
170 | =over 4 |
171 | |
172 | =item trace |
173 | |
174 | =item debug |
175 | |
176 | =item info |
177 | |
178 | =item warn |
179 | |
180 | =item error |
181 | |
182 | =item fatal |
183 | |
184 | =back |
185 | |
186 | For example, if C<env_prefix> is set to C<FREWS_PACKAGE> the following environment |
ae59bbe3 |
187 | variables will be used: |
188 | |
6d77ba42 |
189 | FREWS_PACKAGE_UPTO |
190 | |
ae59bbe3 |
191 | FREWS_PACKAGE_TRACE |
192 | FREWS_PACKAGE_DEBUG |
193 | FREWS_PACKAGE_INFO |
194 | FREWS_PACKAGE_WARN |
195 | FREWS_PACKAGE_ERROR |
196 | FREWS_PACKAGE_FATAL |
197 | |
6d77ba42 |
198 | Note that C<UPTO> is a convenience variable. If you set |
199 | C<< FOO_UPTO=TRACE >> it will enable all log levels. Similarly, if you |
200 | set it to C<FATAL> only fatal will be enabled. |
201 | |
ae59bbe3 |
202 | =head2 $level |
203 | |
204 | Arguments: C<@anything> |
205 | |
206 | All of the following six methods work the same. The basic pattern is: |
207 | |
208 | sub $level { |
209 | my $self = shift; |
210 | |
211 | warn "[$level] " . join qq{\n}, @_; |
212 | if $self->is_$level; |
213 | } |
214 | |
215 | =head3 trace |
216 | |
217 | $l->trace( 'entered method foo with args ' join q{,}, @args ); |
218 | |
219 | =head3 debug |
220 | |
221 | $l->debug( 'entered method foo' ); |
222 | |
223 | =head3 info |
224 | |
225 | $l->info( 'started process foo' ); |
226 | |
227 | =head3 warn |
228 | |
229 | $l->warn( 'possible misconfiguration at line 10' ); |
230 | |
231 | =head3 error |
232 | |
233 | $l->error( 'non-numeric user input!' ); |
234 | |
235 | =head3 fatal |
236 | |
237 | $l->fatal( '1 is never equal to 0!' ); |
238 | |
e7b18282 |
239 | If different levels are specified, appropriate functions named for your custom |
240 | levels work as you expect. |
241 | |
ae59bbe3 |
242 | =head2 is_$level |
243 | |
244 | All of the following six functions just return true if their respective |
245 | environment variable is enabled. |
246 | |
247 | =head3 is_trace |
248 | |
249 | say 'tracing' if $l->is_trace; |
250 | |
251 | =head3 is_debug |
252 | |
253 | say 'debuging' if $l->is_debug; |
254 | |
255 | =head3 is_info |
256 | |
257 | say q{info'ing} if $l->is_info; |
258 | |
259 | =head3 is_warn |
260 | |
261 | say 'warning' if $l->is_warn; |
262 | |
263 | =head3 is_error |
264 | |
265 | say 'erroring' if $l->is_error; |
266 | |
267 | =head3 is_fatal |
268 | |
269 | say q{fatal'ing} if $l->is_fatal; |
270 | |
e7b18282 |
271 | If different levels are specified, appropriate is_$level functions work as you |
272 | would expect. |
273 | |
ae59bbe3 |
274 | =cut |
275 | |