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