File Coverage

blib/lib/Metabrik/Core/Log.pm
Criterion Covered Total %
statement 9 88 10.2
branch 0 34 0.0
condition 0 23 0.0
subroutine 3 14 21.4
pod 10 10 100.0
total 22 169 13.0


line stmt bran cond sub pod time code
1             #
2             # $Id: Log.pm,v a38b58d4db2f 2019/03/13 10:00:56 gomor $
3             #
4             # core::log Brik
5             #
6             package Metabrik::Core::Log;
7 1     1   602 use strict;
  1         2  
  1         28  
8 1     1   5 use warnings;
  1         2  
  1         62  
9              
10             # Breaking.Feature.Fix
11             our $VERSION = '1.40';
12             our $FIX = '0';
13              
14 1     1   6 use base qw(Metabrik);
  1         2  
  1         1245  
15              
16             sub brik_properties {
17             return {
18 0     0 1   revision => '$Revision: a38b58d4db2f $',
19             tags => [ qw(main core) ],
20             attributes => {
21             color => [ qw(0|1) ],
22             level => [ qw(0|1|2|3) ],
23             caller_info_prefix => [ qw(0|1) ],
24             caller_verbose_prefix => [ qw(0|1) ],
25             caller_warning_prefix => [ qw(0|1) ],
26             caller_error_prefix => [ qw(0|1) ],
27             caller_fatal_prefix => [ qw(0|1) ],
28             caller_debug_prefix => [ qw(0|1) ],
29             allow_log_override => [ qw(0|1) ],
30             },
31             attributes_default => {
32             color => 1,
33             level => 1,
34             caller_info_prefix => 0,
35             caller_verbose_prefix => 1,
36             caller_warning_prefix => 1,
37             caller_error_prefix => 1,
38             caller_fatal_prefix => 1,
39             caller_debug_prefix => 1,
40             allow_log_override => 0,
41             },
42             commands => {
43             message => [ qw(string caller|OPTIONAL) ],
44             info => [ qw(string caller|OPTIONAL) ],
45             verbose => [ qw(string caller|OPTIONAL) ],
46             warning => [ qw(string caller|OPTIONAL) ],
47             error => [ qw(string caller|OPTIONAL) ],
48             fatal => [ qw(string caller|OPTIONAL) ],
49             debug => [ qw(string caller|OPTIONAL) ],
50             },
51             require_modules => {
52             'Term::ANSIColor' => [ ],
53             },
54             };
55             }
56              
57             sub brik_preinit {
58 0     0 1   my $self = shift;
59              
60             # We will do a brik_init here, so we have to force the brik_preinit before.
61 0 0         $self->SUPER::brik_preinit(@_) or return;
62              
63 0           my $context = $self->context;
64 0 0         return $self if ! defined($context); # No context, nothing to do.
65              
66             # We replace the current logging Brik by this one,
67             # but only after core::context has been created and initialized.
68             # Ask currently logging Brik if it allows to be overriden
69 0 0 0       if (defined($context) && $context->log->allow_log_override) {
70 0           $context->{log} = $self;
71 0           for my $this (keys %{$context->used}) {
  0            
72 0           $context->{used}->{$this}->{log} = $self;
73             }
74              
75             # We have to init this new log Brik, because previous one
76             # was already inited at this stage. We have to keep the same init context.
77 0 0         $self->brik_init or return $self->log->error("brik_preinit: brik_init error");
78             }
79              
80 0           return $self;
81             }
82              
83             sub brik_init {
84 0     0 1   my $self = shift;
85              
86             # Makes STDOUT file handle unbuffered
87 0           my $current = select;
88 0           select(STDOUT);
89 0           $|++;
90 0           select($current);
91              
92 0           return $self->SUPER::brik_init(@_);
93             }
94              
95             sub message {
96 0     0 1   my $self = shift;
97 0           my ($text, $caller) = @_;
98              
99 0   0       $text ||= 'undef';
100              
101 0           my $message = '';
102 0 0         if (defined($caller)) {
103 0           $caller =~ s/^metabrik:://i;
104 0           $caller = lc($caller);
105 0           $message .= lc($caller).': ';
106             }
107              
108 0           return $message."$text\n";
109             }
110              
111             sub _print_prefix {
112 0     0     my $self = shift;
113 0           my ($str, $color) = @_;
114              
115 0 0         if ($self->color) {
116 0           print $color, "$str ", Term::ANSIColor::RESET();
117             }
118             else {
119 0           print "$str ";
120             }
121              
122 0           return 1;
123             }
124              
125             sub warning {
126 0     0 1   my $self = shift;
127 0           my ($msg, $caller) = @_;
128              
129 0 0         return 1 if ($self->level < 1);
130              
131 0           $self->_print_prefix("[!]", Term::ANSIColor::MAGENTA());
132              
133 0 0         if ($self->caller_warning_prefix) {
134 0   0       print $self->message($msg, ($caller) ||= caller());
135             }
136             else {
137 0           print $self->message($msg);
138             }
139              
140 0           return 1;
141             }
142              
143             sub error {
144 0     0 1   my $self = shift;
145 0           my ($msg, $caller) = @_;
146              
147 0 0         return 1 if ($self->level < 1);
148              
149 0           $self->_print_prefix("[-]", Term::ANSIColor::RED());
150              
151 0 0         if ($self->caller_error_prefix) {
152 0   0       print $self->message($msg, ($caller) ||= caller());
153             }
154             else {
155 0           print $self->message($msg);
156             }
157              
158             # Returning undef is my official way of stating an error occured:
159             # Number 0 is for stating a false condition occured, not not error.
160 0           return;
161             }
162              
163             sub fatal {
164 0     0 1   my $self = shift;
165 0           my ($msg, $caller) = @_;
166              
167             # In log level 0, we print nothing except fatal errors.
168              
169 0           $self->_print_prefix("[F]", Term::ANSIColor::RED());
170              
171 0 0         if ($self->caller_fatal_prefix) {
172 0   0       die($self->message($msg, ($caller) ||= caller()));
173             }
174             else {
175 0           die($self->message($msg));
176             }
177             }
178              
179             sub info {
180 0     0 1   my $self = shift;
181 0           my ($msg, $caller) = @_;
182              
183 0 0         return 1 if ($self->level < 1);
184              
185 0           $self->_print_prefix("[+]", Term::ANSIColor::GREEN());
186              
187 0 0         if ($self->caller_info_prefix) {
188 0   0       print $self->message($msg, ($caller) ||= caller());
189             }
190             else {
191 0           print $self->message($msg);
192             }
193              
194 0           return 1;
195             }
196              
197             sub verbose {
198 0     0 1   my $self = shift;
199 0           my ($msg, $caller) = @_;
200              
201 0 0         return 1 if ($self->level < 2);
202              
203 0           $self->_print_prefix("[*]", Term::ANSIColor::YELLOW());
204              
205 0 0         if ($self->caller_verbose_prefix) {
206 0   0       print $self->message($msg, ($caller) ||= caller());
207             }
208             else {
209 0           print $self->message($msg);
210             }
211              
212 0           return 1;
213             }
214              
215             sub debug {
216 0     0 1   my $self = shift;
217 0           my ($msg, $caller) = @_;
218              
219 0 0         return 1 if ($self->level < 3);
220              
221 0           $self->_print_prefix("[D]", Term::ANSIColor::CYAN());
222              
223 0 0         if ($self->caller_debug_prefix) {
224 0   0       print $self->message($msg, ($caller) ||= caller());
225             }
226             else {
227 0           print $self->message($msg);
228             }
229              
230 0           return 1;
231             }
232              
233             1;
234              
235             __END__