File Coverage

blib/lib/Pcore.pm
Criterion Covered Total %
statement 249 380 65.5
branch 48 118 40.6
condition 12 24 50.0
subroutine 36 47 76.6
pod 0 7 0.0
total 345 576 59.9


line stmt bran cond sub pod time code
1             package Pcore v0.51.0;
2              
3 5     5   1422 use v5.26.0;
  5         14  
4 5     5   1118 use common::header;
  5         12  
  5         115  
5 5     5   1364 use Pcore::Core::Exporter qw[];
  5         10  
  5         113  
6 5     5   1227 use Pcore::Core::Const qw[:CORE];
  5         12  
  5         25  
7              
8             # define %EXPORT_PRAGMA for exporter
9             our $EXPORT_PRAGMA = {
10             ansi => 0, # export ANSI color variables
11             autoload => 0, # export AUTOLOAD
12             class => 0, # package is a Moo class
13             config => 0, # mark package as perl config, used automatically during .perl config evaluation, do not use directly!!!
14             const => 0, # export "const" keyword
15             dist => 0, # mark package aas Pcore dist main module
16             embedded => 0, # run in embedded mode
17             export => 1, # install standart import method
18             inline => 0, # package use Inline
19             l10n => 1, # register package L10N domain
20             result => 0, # export Pcore::Util::Result qw[result]
21             role => 0, # package is a Moo role
22             rpc => 0, # run class as RPC server
23             sql => 0, # export Pcore::Handle::DBI::Const qw[:TYPES]
24             types => 0, # export types
25             };
26              
27             our $EMBEDDED = 0; # Pcore::Core used in embedded mode
28             our $SCRIPT_PATH = $0;
29             our $WIN_ENC = undef;
30             our $CON_ENC = undef;
31              
32             # define alias for export
33             our $P = sub : const {'Pcore'};
34              
35             # configure standard library
36             our $UTIL = {
37             bit => 'Pcore::Util::Bit',
38             ca => 'Pcore::Util::CA',
39             cfg => 'Pcore::Util::Config',
40             class => 'Pcore::Util::Class',
41             data => 'Pcore::Util::Data',
42             date => 'Pcore::Util::Date',
43             digest => 'Pcore::Util::Digest',
44             file => 'Pcore::Util::File',
45             handle => 'Pcore::Handle',
46             hash => 'Pcore::Util::Hash',
47             host => 'Pcore::Util::URI::Host',
48             http => 'Pcore::HTTP',
49             list => 'Pcore::Util::List',
50             mail => 'Pcore::Util::Mail',
51             path => 'Pcore::Util::Path',
52             perl => 'Pcore::Util::Perl',
53             pm => 'Pcore::Util::PM',
54             progress => 'Pcore::Util::Term::Progress',
55             random => 'Pcore::Util::Random',
56             scalar => 'Pcore::Util::Scalar',
57             sys => 'Pcore::Util::Sys',
58             term => 'Pcore::Util::Term',
59             text => 'Pcore::Util::Text',
60             tmpl => 'Pcore::Util::Template',
61             uri => 'Pcore::Util::URI',
62             uuid => 'Pcore::Util::UUID',
63             };
64              
65             sub import {
66 182     182   464 my $self = shift;
67              
68             # get caller
69 182         445 my $caller = caller;
70              
71             # parse tags and pragmas
72 182         698 my $import = Pcore::Core::Exporter::parse_import( $self, @_ );
73              
74 182         336 state $INIT = do {
75              
76             # store -embedded pragma
77 5 50       21 $EMBEDDED = 1 if $import->{pragma}->{embedded};
78              
79 5         1655 require Import::Into;
80 5         11584 require B::Hooks::AtRuntime;
81 5         23434 require B::Hooks::EndOfScope::XS;
82 5         9393 require EV;
83 5         10653 require AnyEvent;
84              
85             # install run-time hook to caller package
86 5         20582 B::Hooks::AtRuntime::at_runtime( \&Pcore::_CORE_RUN );
87              
88             # detect RPC server
89 5 50 33     274 if ( $import->{pragma}->{rpc} && $0 eq '-' ) {
90              
91             # read and unpack boot args from STDIN
92 0         0 my $RPC_BOOT_ARGS = <>;
93              
94 0         0 chomp $RPC_BOOT_ARGS;
95              
96 0         0 require CBOR::XS;
97              
98 0         0 $RPC_BOOT_ARGS = CBOR::XS::decode_cbor( pack 'H*', $RPC_BOOT_ARGS );
99              
100             # init RPC environment
101 0         0 $SCRIPT_PATH = $RPC_BOOT_ARGS->{script_path};
102 0         0 $main::VERSION = version->new( $RPC_BOOT_ARGS->{version} );
103              
104             B::Hooks::AtRuntime::after_runtime(
105             sub {
106 0     0   0 require Pcore::RPC::Server;
107              
108 0         0 Pcore::RPC::Server::run( $caller, $RPC_BOOT_ARGS );
109              
110 0         0 exit;
111             }
112 0         0 );
113             }
114              
115 5         21 _CORE_INIT();
116              
117 5         15 1;
118             };
119              
120             # export header
121 182         4535 common::header->import;
122              
123             # export P sub to avoid indirect calls
124             {
125 5     5   32 no strict qw[refs];
  5         8  
  5         2201  
  182         281  
126              
127 182         290 *{"$caller\::P"} = $P;
  182         1137  
128              
129             # flush the cache exactly once if we make any direct symbol table changes
130             # mro::method_changed_in($caller);
131             }
132              
133             # re-export core packages
134 182         1126 Pcore::Core::Const->import( -caller => $caller );
135              
136 182 100       583 if ( !$import->{pragma}->{config} ) {
137              
138             # process -l10n pragma
139 177 50       468 if ( $import->{pragma}->{l10n} ) {
140 0         0 state $L10N_INIT = !!require Pcore::Core::L10N;
141              
142 0         0 Pcore::Core::L10N->import( -caller => $caller );
143              
144 0         0 Pcore::Core::L10N::register_package_domain( $caller, $import->{pragma}->{l10n} );
145             }
146              
147             # export "dump"
148 177         1049 Pcore::Core::Dump->import( -caller => $caller );
149              
150             # process -export pragma
151 177 100       768 Pcore::Core::Exporter->import( -caller => $caller, -export => $import->{pragma}->{export} ) if $import->{pragma}->{export};
152              
153             # process -inline pragma
154 177 50       465 if ( $import->{pragma}->{inline} ) {
155 0         0 state $INLINE_INIT = !!require Pcore::Core::Inline;
156             }
157              
158             # process -dist pragma
159 177 50       426 $ENV->register_dist($caller) if $import->{pragma}->{dist};
160              
161             # process -const pragma
162 177 100       632 Const::Fast->import::into( $caller, 'const' ) if $import->{pragma}->{const};
163              
164             # process -ansi pragma
165 177 100       9394 if ( $import->{pragma}->{ansi} ) {
166 10         36 Pcore::Core::Const->import( -caller => $caller, qw[:ANSI] );
167             }
168              
169             # import exceptions
170 177         962 Pcore::Core::Exception->import( -caller => $caller );
171              
172             # process -result pragma
173 177 50       431 if ( $import->{pragma}->{result} ) {
174 0         0 state $RESULT_INIT = !!require Pcore::Util::Result;
175              
176 0         0 Pcore::Util::Result->import( -caller => $caller, qw[result] );
177             }
178              
179             # process -sql pragma
180 177 50       448 if ( $import->{pragma}->{sql} ) {
181 0         0 state $SQL_INIT = !!require Pcore::Handle::DBI::Const;
182              
183 0         0 Pcore::Handle::DBI::Const->import( -caller => $caller, qw[:TYPES] );
184             }
185              
186             # re-export Moo
187 177 100 100     634 if ( $import->{pragma}->{class} || $import->{pragma}->{role} ) {
188              
189             # install universal serializer methods
190             B::Hooks::EndOfScope::XS::on_scope_end(
191             sub {
192 78     78   49715 _namespace_clean($caller);
193              
194 5     5   32 no strict qw[refs];
  5         9  
  5         3551  
195              
196 78 50       846 if ( my $ref = $caller->can('TO_DATA') ) {
197 0 0       0 *{"$caller\::TO_JSON"} = $ref unless $caller->can('TO_JSON');
  0         0  
198              
199 0 0       0 *{"$caller\::TO_CBOR"} = $ref unless $caller->can('TO_CBOR');
  0         0  
200             }
201              
202 78         237 return;
203             }
204 78         623 );
205              
206 78         1449 $import->{pragma}->{types} = 1;
207              
208 78 100       264 if ( $import->{pragma}->{class} ) {
    50          
209 69         193 _import_moo( $caller, 0 );
210             }
211             elsif ( $import->{pragma}->{role} ) {
212 9         35 _import_moo( $caller, 1 );
213             }
214              
215             # reconfigure warnings, after Moo exported
216 78         1751 common::header->import;
217              
218             # apply default roles
219             # _apply_roles( $caller, qw[Pcore::Core::Autoload::Role] );
220             }
221              
222             # export types
223 177 100       585 _import_types($caller) if $import->{pragma}->{types};
224              
225             # process -autoload pragma, should be after the -role to support AUTOLOAD in Moo roles
226             # NOTE !!!WARNING!!! AUTOLOAD should be exported after Moo::Role, so Moo::Role can re-export this method
227 177 50       545 if ( $import->{pragma}->{autoload} ) {
228 0         0 state $init = !!require Pcore::Core::Autoload;
229              
230 0         0 Pcore::Core::Autoload->import( -caller => $caller );
231             }
232             }
233              
234 182         14017 return;
235             }
236              
237 78     78   163 sub _namespace_clean ($class) {
  78         181  
  78         133  
238 78         152 state $EXCEPT = do {
239 5         31 require Sub::Util;
240 5         1539 require Package::Stash;
241              
242 5         18335 { import => 1,
243             AUTOLOAD => 1,
244             };
245             };
246              
247 78         1181 my $stash = Package::Stash->new($class);
248              
249 78         2644 for my $subname ( $stash->list_all_symbols('CODE') ) {
250 5914         26501 my $fullname = Sub::Util::subname( $stash->get_symbol("&$subname") );
251              
252 5914 100 66     23768 if ( "$class\::$subname" ne $fullname && !exists $EXCEPT->{$subname} && substr( $subname, 0, 1 ) ne q[(] ) {
      100        
253             my @symbols = map {
254 4756         6295 my $name = $_ . $subname;
  19024         22783  
255              
256 19024         42211 my $def = $stash->get_symbol($name);
257              
258 19024 50       31946 defined($def) ? [ $name, $def ] : ()
259             } qw[$ @ %], q[];
260              
261 4756         14106 $stash->remove_glob($subname);
262              
263 4756         8678 $stash->add_symbol( $_->@* ) for @symbols;
264             }
265             }
266              
267 78         606 return;
268             }
269              
270 78     78   117 sub _import_moo ( $caller, $role ) {
  78         120  
  78         114  
  78         109  
271 78 100       162 if ($role) {
272 9         61 Moo::Role->import::into($caller);
273             }
274             else {
275 69         446 Moo->import::into($caller);
276              
277 69         66548 MooX::TypeTiny->import::into($caller);
278             }
279              
280             # install "has" hook
281             {
282 5     5   33 no strict qw[refs];
  5         77  
  5         339  
  78         188227  
283              
284 78         155 my $has = *{"$caller\::has"}{CODE};
  78         330  
285              
286 5     5   29 no warnings qw[redefine];
  5         7  
  5         6946  
287              
288 78         305 *{"$caller\::has"} = sub {
289 725     725   122060 my ( $name_proto, %spec ) = @_;
290              
291             # auto add builder if lazy and builder or default is not specified
292 725 0 33     2166 $spec{builder} = 1 if $spec{lazy} && !exists $spec{default} && !exists $spec{builder};
      33        
293              
294 725         2103 $has->( $name_proto, %spec );
295 78         368 };
296             }
297              
298 78         170 return;
299             }
300              
301 78     78   123 sub _import_types ($caller) {
  78         154  
  78         98  
302 78         134 state $init = do {
303 5         48 local $ENV{PERL_TYPES_STANDARD_STRICTNUM} = 0; # 0 - Num = LaxNum, 1 - Num = StrictNum
304              
305 5         1596 require Pcore::Core::Types;
306 5         51 require Types::TypeTiny;
307 5         24 require Types::Standard;
308 5         1492 require Types::Common::Numeric;
309              
310             # require Types::Common::String;
311             # require Types::Encodings();
312             # require Types::XSD::Lite();
313              
314 5         50543 1;
315             };
316              
317 78         713 Types::TypeTiny->import( { into => $caller }, qw[StringLike HashLike ArrayLike CodeLike TypeTiny] );
318              
319 78         35852 Types::Standard->import( { into => $caller }, ':types' );
320              
321 78         308138 Types::Common::Numeric->import( { into => $caller }, ':types' );
322              
323 78         88566 Pcore::Core::Types->import( { into => $caller }, ':types' );
324              
325 78         44892 return;
326             }
327              
328 0     0   0 sub _apply_roles ( $caller, @roles ) {
  0         0  
  0         0  
  0         0  
329 0         0 Moo::Role->apply_roles_to_package( $caller, @roles );
330              
331 0 0       0 if ( Moo::Role->is_role($caller) ) {
332 0         0 Moo::Role->_maybe_reset_handlemoose($caller); ## no critic qw[Subroutines::ProtectPrivateSubs]
333             }
334             else {
335 0         0 Moo->_maybe_reset_handlemoose($caller); ## no critic qw[Subroutines::ProtectPrivateSubs]
336             }
337              
338 0         0 return;
339             }
340              
341             sub _CORE_INIT {
342 5     5   1471 require Pcore::Core::Dump;
343 5         46 Pcore::Core::Dump->import(':CORE');
344              
345             # set default fallback mode for all further :encoding I/O layers
346 5         26 $PerlIO::encoding::fallback = Encode::FB_CROAK() | Encode::STOP_AT_PARTIAL();
347              
348 5 50       16 if ($MSWIN) {
349 0         0 require Win32;
350 0         0 require Win32::Console::ANSI;
351              
352 0         0 $WIN_ENC = 'cp' . Win32::GetACP();
353 0         0 $CON_ENC = Win32::GetConsoleCP();
354              
355 0 0       0 if ($CON_ENC) {
356 0         0 $CON_ENC = 'cp' . $CON_ENC;
357              
358             # check if we can properly decode STDIN under MSWIN
359             eval {
360 0 0       0 Encode::perlio_ok($CON_ENC) or die;
361              
362 0         0 1;
363 0 0       0 } || do {
364 0         0 say qq[FATAL: Console input encoding "$CON_ENC" isn't supported. Use chcp to change console codepage.];
365              
366 0         0 exit 1;
367             };
368             }
369             else {
370 0         0 $CON_ENC = undef;
371             }
372             }
373             else {
374 5         12 $CON_ENC = 'UTF-8';
375 5         13 $WIN_ENC = 'UTF-8';
376             }
377              
378             # decode @ARGV
379 5         14 for (@ARGV) {
380 0         0 $_ = Encode::decode( $WIN_ENC, $_, Encode::FB_CROAK() );
381             }
382              
383             # configure run-time environment
384 5         1790 require Pcore::Core::Env;
385              
386             # STDIN
387 5 50       43 if ( -t *STDIN ) { ## no critic qw[InputOutput::ProhibitInteractiveTest]
388 0 0       0 if ($MSWIN) {
389 0 0       0 binmode *STDIN, ":raw:crlf:encoding($CON_ENC)" or die;
390             }
391             else {
392 0 0       0 binmode *STDIN, ':raw:encoding(UTF-8)' or die;
393             }
394             }
395             else {
396 5 50       38 binmode *STDIN, ':raw' or die;
397             }
398              
399             # STDOUT
400 5 50       114 open our $STDOUT_UTF8, '>&STDOUT' or $STDOUT_UTF8 = *STDOUT; ## no critic qw[InputOutput::ProhibitBarewordFileHandles]
401              
402 5         23 _config_stdout($STDOUT_UTF8);
403              
404             # STDERR
405 5 50       73 open our $STDERR_UTF8, '>&STDERR' or $STDERR_UTF8 = *STDERR; ## no critic qw[InputOutput::ProhibitBarewordFileHandles]
406              
407 5         19 _config_stdout($STDERR_UTF8);
408              
409 5         18 select $STDOUT_UTF8; ## no critic qw[InputOutput::ProhibitOneArgSelect]
410              
411 5         27 STDOUT->autoflush(1);
412 5         187 STDERR->autoflush(1);
413              
414 5         132 $STDOUT_UTF8->autoflush(1);
415 5         111 $STDERR_UTF8->autoflush(1);
416              
417 5         1493 require Pcore::Core::Exception; # set $SIG{__DIE__}, $SIG{__WARN__}, $SIG->{INT}, $SIG->{TERM} handlers
418              
419 5         1263 require Pcore::AE::Patch;
420              
421 5         21 return;
422             }
423              
424             # TODO add PerlIO::removeEsc layer
425 10     10   14 sub _config_stdout ($h) {
  10         21  
  10         13  
426 10 50       23 if ($MSWIN) {
427 0 0       0 if ( -t $h ) { ## no critic qw[InputOutput::ProhibitInteractiveTest]
428 0         0 state $init = !!require Pcore::Core::PerlIOviaWinUniCon;
429              
430 0 0       0 binmode $h, ':raw:via(Pcore::Core::PerlIOviaWinUniCon)' or die; # terminal
431             }
432             else {
433 0 0       0 binmode $h, ':raw:encoding(UTF-8)' or die; # file TODO +RemoveESC
434             }
435             }
436             else {
437 10 50       34 if ( -t $h ) { ## no critic qw[InputOutput::ProhibitInteractiveTest]
438 0 0       0 binmode $h, ':raw:encoding(UTF-8)' or die; # terminal
439             }
440             else {
441 5 50   5   27 binmode $h, ':raw:encoding(UTF-8)' or die; # file TODO +RemoveESC
  5         9  
  5         31  
  10         172  
442             }
443             }
444              
445 10         3497 return;
446             }
447              
448             sub _CORE_RUN {
449              
450             # EMBEDDED mode, if run not from INIT block or -embedded pragma specified:
451             # CLI not parsed / processed;
452             # process permissions not changed;
453             # process will not daemonized;
454              
455 5 50   5   416 if ( !$EMBEDDED ) {
456 5         1515 state $INIT_CLI = !!require Pcore::Core::CLI;
457              
458 5         37 Pcore::Core::CLI->new( { class => 'main' } )->run( \@ARGV );
459              
460 5 50       52 if ( !$MSWIN ) {
461              
462             # GID is inherited from UID by default
463 5 50 33     26 if ( defined $ENV->{UID} && !defined $ENV->{GID} ) {
464 0 0       0 my $uid = $ENV->{UID} =~ /\A\d+\z/sm ? $ENV->{UID} : getpwnam $ENV->{UID};
465              
466 0 0       0 die qq[Can't find uid "$ENV->{UID}"] if !defined $uid;
467              
468 0         0 $ENV->{GID} = [ getpwuid $uid ]->[2];
469             }
470              
471             # change priv
472 5         45 Pcore->pm->change_priv( gid => $ENV->{GID}, uid => $ENV->{UID} );
473              
474 5 50       24 P->pm->daemonize if $ENV->{DAEMONIZE};
475             }
476             }
477              
478 5         46 return;
479             }
480              
481             # L10N
482 0     0 0 0 sub set_locale ( $self, $locale = undef ) {
  0         0  
  0         0  
  0         0  
483 0         0 state $L10N_INIT = !!require Pcore::Core::L10N;
484              
485 0         0 return Pcore::Core::L10N::set_locale($locale);
486             }
487              
488             # AUTOLOAD
489 32     32   2422 sub AUTOLOAD ( $self, @ ) { ## no critic qw[ClassHierarchies::ProhibitAutoloading]
  32         66  
  32         44  
490 32         196 my $util = our $AUTOLOAD =~ s/\A.*:://smr;
491              
492 32 50       175 die qq[Unregistered Pcore::Util "$util".] unless my $class = $UTIL->{$util};
493              
494 32         9547 require $class =~ s[::][/]smgr . '.pm';
495              
496 5     5   34 no strict qw[refs];
  5         9  
  5         1355  
497              
498 32 100       449 if ( $class->can('new') ) {
499 13     191   1465 eval <<"PERL"; ## no critic qw[BuiltinFunctions::ProhibitStringyEval ErrorHandling::RequireCheckingReturnValueOfEval]
  191         8925  
  191         3267  
  119         10060  
  119         1917  
  41         11463  
  41         734  
  73         128  
  73         1431  
500             *{$util} = sub {
501             shift;
502              
503             return $class->new(\@_);
504             };
505             PERL
506             }
507             else {
508              
509             # create util namespace with AUTOLOAD method
510 5 50   5   43 eval <<"PERL"; ## no critic qw[BuiltinFunctions::ProhibitStringyEval ErrorHandling::RequireCheckingReturnValueOfEval]
  5 50   5   10  
  5 50   5   45  
  5 50   5   34  
  5     5   10  
  5     5   576  
  5     4   33  
  5     4   7  
  5     11   29  
  5     5   37  
  5     11   12  
  5     7   651  
  5     6   39  
  5         12  
  5         32  
  5         33  
  5         11  
  5         590  
  4         24  
  4         8  
  4         20  
  4         27  
  4         11  
  4         521  
  19         1673  
  11         55  
  11         23  
  11         54  
  11         1235  
  11         56  
  11         194  
  5         29  
  5         14  
  5         28  
  5         515  
  5         26  
  5         86  
  11         60  
  11         26  
  11         61  
  11         1195  
  11         57  
  11         211  
  7         38  
  7         13  
  7         38  
  7         696  
  7         37  
  7         135  
  6         15  
  6         26  
  5         15  
  5         18  
  7         18  
  7         26  
  5         15  
  5         20  
  9         21  
  9         31  
  6         14  
  6         24  
  10         1414  
  10         84  
  1         3  
  1         4  
511             package $self\::Util::_$util;
512              
513             use Pcore;
514              
515             sub AUTOLOAD {
516             my \$method = our \$AUTOLOAD =~ s/\\A.*:://smr;
517              
518             no strict qw[refs];
519              
520             die qq[Sub "$class\::\$method" is not defined] if !defined &{"$class\::\$method"};
521              
522             # install method wrapper
523             eval <<"EVAL";
524             *{"$self\::Util::_$util\::\$method"} = sub {
525             shift;
526              
527             return &$class\::\$method;
528             };
529             EVAL
530              
531             goto &{\$method};
532             }
533             PERL
534              
535             # create util namespace access method
536 19     19   224 *{$util} = sub : const {"$self\::Util::_$util"};
  19         75  
  19         131  
537             }
538              
539 32         147 goto &{$util};
  32         981  
540             }
541              
542 0     0 0   sub init_demolish ( $self, $class ) {
  0            
  0            
  0            
543 0           state $init = do {
544 0           require Method::Generate::DemolishAll;
545              
546             # avoid to call Method::Generate::DemolishAll->generate_method again from Moo ->new method
547 0           my $generate_method = \&Method::Generate::DemolishAll::generate_method;
548              
549 5     5   30 no warnings qw[redefine];
  5         10  
  5         3188  
550              
551             *Method::Generate::DemolishAll::generate_method = sub {
552 0     0     my ( $self, $into ) = @_;
553              
554 0 0         return if *{ Moo::_Utils::_getglob("$into\::DEMOLISHALL") }{CODE};
  0            
555              
556 0           return $generate_method->(@_);
557 0           };
558             };
559              
560             # install DEMOLISH to make it works, when object is instantiated with direct "bless" call
561             # https://rt.cpan.org/Ticket/Display.html?id=116590
562 0 0 0       Method::Generate::DemolishAll->new->generate_method($class) if $class->can('DEMOLISH') && $class->isa('Moo::Object');
563              
564 0           return;
565             }
566              
567             # EVENT
568             sub _init_ev {
569 0     0     state $broker = do {
570 0           require Pcore::Core::Event;
571              
572 0           my $_broker = Pcore::Core::Event->new;
573              
574             # set default log channels
575 0           $_broker->listen_events( 'LOG.EXCEPTION.*', 'stderr:' );
576              
577             # file logs are disabled by default for scripts, that are not part of the distribution
578 0 0         if ( $ENV->dist ) {
579 0           $_broker->listen_events( 'LOG.EXCEPTION.FATAL', 'file:fatal.log' );
580 0           $_broker->listen_events( 'LOG.EXCEPTION.ERROR', 'file:error.log' );
581 0           $_broker->listen_events( 'LOG.EXCEPTION.WARN', 'file:warn.log' );
582             }
583              
584 0           $_broker;
585             };
586              
587 0           return $broker;
588             }
589              
590 0     0 0   sub listen_events ( $self, $masks, @listeners ) {
  0            
  0            
  0            
  0            
591 0           state $broker = _init_ev();
592              
593 0           return $broker->listen_events( $masks, @listeners );
594             }
595              
596 0     0 0   sub has_listeners ( $self, $key ) {
  0            
  0            
  0            
597 0           state $broker = _init_ev();
598              
599 0           return $broker->has_listeners($key);
600             }
601              
602 0     0 0   sub forward_event ( $self, $ev ) {
  0            
  0            
  0            
603 0           state $broker = _init_ev();
604              
605 0           return $broker->forward_event($ev);
606             }
607              
608 0     0 0   sub fire_event ( $self, $key, $data = undef ) {
  0            
  0            
  0            
  0            
609 0           state $broker = _init_ev();
610              
611 0           my $ev = {
612             key => $key,
613             data => $data,
614             };
615              
616 0           return $broker->forward_event($ev);
617             }
618              
619 0     0 0   sub sendlog ( $self, $key, $title, $data = undef ) {
  0            
  0            
  0            
  0            
  0            
620 0           state $broker = _init_ev();
621              
622 0 0         return if !$broker->has_listeners("LOG.$key");
623              
624 0           my $ev;
625              
626 0           ( $ev->{channel}, $ev->{level} ) = split /[.]/sm, $key, 2;
627              
628 0 0         die q[Log level must be specified] unless $ev->{level};
629              
630 0           $ev->{key} = "LOG.$key";
631 0           $ev->{timestamp} = Time::HiRes::time();
632 0           \$ev->{title} = \$title;
633 0           \$ev->{data} = \$data;
634              
635 0           $broker->forward_event($ev);
636              
637 0           return;
638             }
639              
640             1;
641             ## -----SOURCE FILTER LOG BEGIN-----
642             ##
643             ## PerlCritic profile "common" policy violations:
644             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
645             ## | Sev. | Lines | Policy |
646             ## |======+======================+================================================================================================================|
647             ## | 3 | 65 | Subroutines::ProhibitExcessComplexity - Subroutine "import" with high complexity score (22) |
648             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
649             ## | 3 | 86 | Variables::ProtectPrivateVars - Private variable used |
650             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
651             ## | 3 | 253 | BuiltinFunctions::ProhibitComplexMappings - Map blocks should have a single statement |
652             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
653             ## | 3 | | Subroutines::ProhibitUnusedPrivateSubroutines |
654             ## | | 328 | * Private subroutine/method '_apply_roles' declared but not used |
655             ## | | 448 | * Private subroutine/method '_CORE_RUN' declared but not used |
656             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
657             ## | 3 | 360, 389, 392, 396, | ErrorHandling::RequireCarping - "die" used instead of "croak" |
658             ## | | 430, 433, 438, 441, | |
659             ## | | 466, 492, 628 | |
660             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
661             ## | 3 | 554 | Subroutines::ProtectPrivateSubs - Private subroutine/method used |
662             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
663             ## | 2 | 263 | ControlStructures::ProhibitPostfixControls - Postfix control "for" used |
664             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
665             ## | 1 | 364 | InputOutput::RequireCheckedSyscalls - Return value of flagged function ignored - say |
666             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
667             ##
668             ## -----SOURCE FILTER LOG END-----
669             __END__
670             =pod
671              
672             =encoding utf8
673              
674             =head1 NAME
675              
676             Pcore - perl applications development environment
677              
678             =begin HTML
679              
680             <p><a href="https://metacpan.org/pod/Pcore" target="_blank"><img alt="CPAN version" src="https://badge.fury.io/pl/Pcore.svg"></a></p>
681              
682             =end HTML
683              
684             =head1 SYNOPSIS
685              
686             use Pcore -<pragma> qw[<import>], {config};
687              
688             =head1 DESCRIPTION
689              
690             Documentation will be provided later.
691              
692             =head1 ENVIRONMENT
693              
694             =over
695              
696             =item * PCORE_LIB
697              
698             =back
699              
700             =cut