File Coverage

blib/lib/Siffra/Base.pm
Criterion Covered Total %
statement 63 90 70.0
branch 3 12 25.0
condition 3 8 37.5
subroutine 18 21 85.7
pod 2 2 100.0
total 89 133 66.9


line stmt bran cond sub pod time code
1             package Siffra::Base;
2              
3 1     1   54980 use 5.014;
  1         3  
4 1     1   5 use strict;
  1         1  
  1         18  
5 1     1   3 use warnings;
  1         2  
  1         30  
6 1     1   4 use Carp;
  1         2  
  1         56  
7 1     1   529 use utf8;
  1         13  
  1         4  
8 1     1   540 use Data::Dumper;
  1         6506  
  1         71  
9 1     1   399 use DDP;
  1         34469  
  1         9  
10 1     1   450 use Log::Any qw($log);
  1         8297  
  1         6  
11 1     1   1989 use Scalar::Util qw(blessed);
  1         3  
  1         63  
12             $Carp::Verbose = 1;
13              
14             $| = 1; #autoflush
15              
16             use constant {
17             FALSE => 0,
18             TRUE => 1,
19 1   50     88 DEBUG => $ENV{ DEBUG } // 0,
20 1     1   25 };
  1         3  
21              
22             BEGIN
23             {
24 1     1   6 use Exporter ();
  1         1  
  1         25  
25 1     1   5 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         2  
  1         91  
26 1     1   3 $VERSION = '0.06';
27 1         13 @ISA = qw(Exporter);
28              
29             #Give a hoot don't pollute, do not export more than needed by default
30 1         3 @EXPORT = qw();
31 1         2 @EXPORT_OK = qw();
32 1         255 %EXPORT_TAGS = ();
33             } ## end BEGIN
34              
35             BEGIN
36             {
37 1     1   52 binmode( STDOUT, ":encoding(UTF-8)" );
  1     1   6  
  1         2  
  1         6  
38 1         9722 binmode( STDERR, ":encoding(UTF-8)" );
39              
40             $SIG{ __DIE__ } = sub {
41 1         5 $log->debug( 'Entrando em __DIE__', { package => __PACKAGE__ } );
42 1 50       5 if ( $^S )
43             {
44 1         3 $log->debug( 'Entrando em __DIE__ eval {}', { package => __PACKAGE__ } );
45              
46             # We're in an eval {} and don't want log
47             # this message but catch it later
48 1         23 return;
49             } ## end if ( $^S )
50              
51 0         0 ( my $message = $_[ 0 ] ) =~ s/\n|\r//g;
52 0         0 $log->fatal( $message, { package => __PACKAGE__ } );
53              
54 0         0 p @_;
55 0         0 die Dumper @_; # Now terminate really
56 1         41 };
57              
58             $SIG{ __WARN__ } = sub {
59 0         0 state $count = 0;
60 0         0 ( my $message = $_[ 0 ] ) =~ s/\n|\r//g;
61 0 0       0 if ( $log )
62             {
63 0         0 $log->warn( $message, { package => __PACKAGE__, count => $count++, global_phase => ${^GLOBAL_PHASE} } );
64             }
65 1         483 };
66             } ## end BEGIN
67              
68             =head2 C
69              
70             Usage : $self->block_new_method() within text_pm_file()
71             Purpose : Build 'new()' method as part of a pm file
72             Returns : String holding sub new.
73             Argument : $module: pointer to the module being built
74             (as there can be more than one module built by EU::MM);
75             for the primary module it is a pointer to $self
76             Throws : n/a
77             Comment : This method is a likely candidate for alteration in a subclass,
78             e.g., pass a single hash-ref to new() instead of a list of
79             parameters.
80              
81             =cut
82              
83             sub new
84             {
85 1     1 1 71 my ( $class, %parameters ) = @_;
86 1         11 $log->debug( "new", { progname => $0, pid => $$, perl_version => $], package => __PACKAGE__ } );
87              
88 1         5 my $self = {};
89              
90 1   33     6 $self = bless( $self, ref( $class ) || $class );
91              
92 1         3 return $self;
93             } ## end sub new
94              
95             sub _initialize()
96             {
97 0     0   0 my ( $self, %parameters ) = @_;
98 0         0 $log->debug( "_initialize", { package => __PACKAGE__ } );
99             }
100              
101             sub END
102             {
103 1     1   115 $log->debug( "END", { package => __PACKAGE__ } );
104 1         3 eval { $log->{ adapter }->{ dispatcher }->{ outputs }->{ Email }->flush; };
  1         52  
105             }
106              
107             =head2 C
108              
109             Usage : $self->block_new_method() within text_pm_file()
110             Purpose : Build 'new()' method as part of a pm file
111             Returns : String holding sub new.
112             Argument : $module: pointer to the module being built
113             (as there can be more than one module built by EU::MM);
114             for the primary module it is a pointer to $self
115             Throws : n/a
116             Comment : This method is a likely candidate for alteration in a subclass,
117             e.g., pass a single hash-ref to new() instead of a list of
118             parameters.
119              
120             =cut
121              
122             sub AUTOLOAD
123             {
124 0     0   0 my ( $self, @parameters ) = @_;
125 0         0 our $AUTOLOAD;
126 0 0       0 return if ( $AUTOLOAD =~ /DESTROY/ );
127              
128             # Remove qualifier from original method name...
129 0         0 my $called = $AUTOLOAD =~ s/.*:://r;
130              
131             # Is there an attribute of that name?
132 0 0       0 die "No such attribute ****[ $called ]****" unless exists $self->{ $called };
133              
134             # If so, return it...
135 0         0 return $self->{ $called };
136             } ## end sub AUTOLOAD
137              
138             sub DESTROY
139             {
140 1     1   481 my ( $self, %parameters ) = @_;
141              
142 1 50       5 if ( ${^GLOBAL_PHASE} eq 'DESTRUCT' )
143             {
144 0         0 eval { $log->{ adapter }->{ dispatcher }->{ outputs }->{ Email }->flush; };
  0         0  
145 0         0 return;
146             }
147              
148 1 50 33     10 if ( blessed( $self ) && $self->isa( __PACKAGE__ ) )
149             {
150 1         6 $log->debug( "DESTROY", { package => __PACKAGE__, GLOBAL_PHASE => ${^GLOBAL_PHASE}, blessed => TRUE } );
151             }
152             else
153             {
154             # TODO
155             }
156             } ## end sub DESTROY
157              
158             =head2 C
159             =cut
160              
161             sub getLogger()
162             {
163 0     0 1   my ( $package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash ) = caller( 0 ); # EU mesmo
164 0           my ( $parent_package, $parent_filename, $parent_line, $parent_subroutine, $parent_hasargs, $parent_wantarray, $parent_evaltext, $parent_is_require, $parent_hints, $parent_bitmask, $parent_hinthash ) = caller( 1 ); # QUEM me chamou
165              
166 0           my $log = Log::Any->get_logger();
167              
168 0           $log->context->{ subroutine } = $subroutine;
169 0           $log->context->{ parent_subroutine } = $parent_subroutine;
170 0           my ( $self, %parameters ) = @_;
171              
172 0           $log->debug( $subroutine, { package => __PACKAGE__, file => __FILE__ } );
173              
174 0           return $log;
175              
176             # ->context = {
177             # me => $subroutine,
178             # parent => $parent_subroutine
179             # };
180             } ## end sub getLogger
181              
182             #################### main pod documentation begin ###################
183             ## Below is the stub of documentation for your module.
184             ## You better edit it!
185              
186             =encoding UTF-8
187              
188              
189             =head1 NAME
190              
191             Siffra::Base - Siffra Base Module
192              
193             =head1 SYNOPSIS
194              
195             use Siffra::Base;
196             blah blah blah
197              
198              
199             =head1 DESCRIPTION
200              
201             Stub documentation for this module was created by ExtUtils::ModuleMaker.
202             It looks like the author of the extension was negligent enough
203             to leave the stub unedited.
204              
205             Blah blah blah.
206              
207              
208             =head1 USAGE
209              
210              
211              
212             =head1 BUGS
213              
214              
215              
216             =head1 SUPPORT
217              
218              
219              
220             =head1 AUTHOR
221              
222             Luiz Benevenuto
223             CPAN ID: LUIZBENE
224             Siffra TI
225             luiz@siffra.com.br
226             https://siffra.com.br
227              
228             =head1 COPYRIGHT
229              
230             This program is free software; you can redistribute
231             it and/or modify it under the same terms as Perl itself.
232              
233             The full text of the license can be found in the
234             LICENSE file included with this module.
235              
236              
237             =head1 SEE ALSO
238              
239             perl(1).
240              
241             =cut
242              
243             #################### main pod documentation end ###################
244              
245             1;
246              
247             # The preceding line will help the module return a true value
248