File Coverage

blib/lib/Pcore/Core/Env.pm
Criterion Covered Total %
statement 119 201 59.2
branch 25 88 28.4
condition 7 27 25.9
subroutine 17 21 80.9
pod 0 4 0.0
total 168 341 49.2


line stmt bran cond sub pod time code
1             package Pcore::Core::Env;
2              
3 5     5   31 use Pcore -class;
  5         8  
  5         30  
4 5     5   873 use Config;
  5         10  
  5         1056  
5 5     5   966 use File::Spec qw[]; ## no critic qw[Modules::ProhibitEvilModules] needed to find system temp dir
  5         10  
  5         74  
6 5     5   17 use Cwd qw[]; ## no critic qw[Modules::ProhibitEvilModules]
  5         8  
  5         67  
7 5     5   1535 use Pcore::Dist;
  5         15  
  5         163  
8 5     5   2119 use Pcore::Core::Env::Share;
  5         14  
  5         211  
9 5     5   40 use Fcntl qw[LOCK_EX SEEK_SET];
  5         10  
  5         13020  
10              
11             has is_par => ( is => 'lazy', isa => Bool, init_arg => undef ); # process run from PAR distribution
12             has _main_dist => ( is => 'lazy', isa => Maybe [ InstanceOf ['Pcore::Dist'] ], init_arg => undef ); # main dist
13             has pcore => ( is => 'lazy', isa => InstanceOf ['Pcore::Dist'], init_arg => undef ); # pcore dist
14             has share => ( is => 'lazy', isa => InstanceOf ['Pcore::Core::Env::Share'], init_arg => undef ); # share object
15             has _dist_idx => ( is => 'lazy', isa => HashRef, default => sub { {} }, init_arg => undef ); # registered dists. index
16             has cli => ( is => 'ro', isa => HashRef, init_arg => undef ); # parsed CLI data
17             has user_cfg_path => ( is => 'lazy', isa => Str, init_arg => undef );
18             has user_cfg => ( is => 'lazy', isa => HashRef, init_arg => undef ); # $HOME/.pcore/pcore.ini config
19              
20             has can_scan_deps => ( is => 'lazy', isa => Bool, init_arg => undef );
21              
22             _normalize_inc();
23              
24             # create $ENV object
25             $ENV = __PACKAGE__->new; ## no critic qw[Variables::RequireLocalizedPunctuationVars]
26              
27             $ENV->_INIT;
28              
29             _configure_inc();
30              
31             sub _normalize_inc {
32 5     5   11 my @inc;
33              
34             my $inc_index;
35              
36             # index @INC, resolve @INC paths, remove duplicates, preserve REF items
37 5         14 for my $inc_path (@INC) {
38 50 50       102 if ( ref $inc_path ) {
39 0         0 push @inc, $inc_path;
40              
41 0         0 next;
42             }
43              
44             # ignore non-exists path
45 50 50       664 next if !-d $inc_path;
46              
47 50         838 $inc_path = P->path( $inc_path, is_dir => 1 )->realpath->canonpath;
48              
49             # ignore already added path
50 50 100       484 if ( !exists $inc_index->{$inc_path} ) {
51 40         90 $inc_index->{$inc_path} = 1;
52              
53 40         94 push @inc, $inc_path;
54             }
55             }
56              
57 5         30 @INC = @inc; ## no critic qw[Variables::RequireLocalizedPunctuationVars]
58              
59 5         21 return;
60             }
61              
62             sub _configure_inc {
63 5     5   10 my @inc;
64              
65             my $inc_index;
66              
67             # index @INC, resolve @INC paths, remove duplicates, preserve REF items
68 5         16 for my $inc_path (@INC) {
69 40 50       71 if ( ref $inc_path ) {
70 0         0 push @inc, $inc_path;
71              
72 0         0 next;
73             }
74              
75             # ignore already added path
76 40 50       69 if ( !exists $inc_index->{$inc_path} ) {
77 40         66 $inc_index->{$inc_path} = 1;
78              
79 40         62 push @inc, $inc_path;
80             }
81             }
82              
83             # not for PAR
84 5 50       84 if ( !$ENV->is_par ) {
85 5         43 my $is_module_build_test = 0; # $ENV->dist && exists $inc_index->{ $ENV->dist->root . 'blib/lib' } ? 1 : 0;
86              
87             # add dist lib and PCORE_LIB to @INC only if we are int on the PAR archive and not in the Module::Build testing environment
88             # under Module::Build dist lib is already added and PCORE_LIB is not added to emulate clean CPAN installation
89 5 50       16 if ( !$is_module_build_test ) {
90 5         9 my $dist_lib_path;
91              
92             # detect dist lib path
93 5 50 33     13 if ( $ENV->dist && !exists $inc_index->{ $ENV->dist->root . 'lib' } && -d $ENV->dist->root . 'lib/' ) {
      33        
94 5         152 $dist_lib_path = $ENV->dist->root . 'lib';
95              
96 5         52 $inc_index->{$dist_lib_path} = 1;
97             }
98              
99             # find and add other dist libs to @INC
100 5 50 33     25 if ( $ENV{PCORE_LIB} && -d $ENV{PCORE_LIB} ) {
101 0         0 for my $dir ( sort { $b cmp $a } P->file->read_dir( $ENV{PCORE_LIB}, full_path => 1 )->@* ) {
  0         0  
102 0 0 0     0 if ( !exists $inc_index->{qq[$dir/lib]} && -d qq[$dir/lib/] && Pcore::Dist->dir_is_dist_root($dir) ) {
      0        
103 0         0 $inc_index->{qq[$dir/lib]} = 1;
104              
105 0         0 unshift @inc, qq[$dir/lib];
106             }
107             }
108             }
109              
110             # register dist lib path in @INC, dist lib path is always on top of other dists
111 5 50       35 unshift @inc, $dist_lib_path if $dist_lib_path;
112             }
113             }
114              
115 5         38 @INC = @inc; ## no critic qw[Variables::RequireLocalizedPunctuationVars]
116              
117 5         38 return;
118             }
119              
120 5     5   10 sub _INIT ($self) {
  5         11  
  5         11  
121 5         56 $self->{START_DIR} = P->file->cwd->to_string;
122              
123 5 50 33     40 if ( $Pcore::SCRIPT_PATH eq '-e' || $Pcore::SCRIPT_PATH eq '-' ) {
124 0         0 $self->{SCRIPT_NAME} = '-e';
125 0         0 $self->{SCRIPT_DIR} = $self->{START_DIR};
126             }
127             else {
128 5 50       117 die qq[Cannot find current script "$Pcore::SCRIPT_PATH"] if !-f $Pcore::SCRIPT_PATH;
129              
130 5         92 my $path = P->path($Pcore::SCRIPT_PATH)->realpath;
131              
132 5         102 $self->{SCRIPT_NAME} = $path->filename;
133 5         112 $self->{SCRIPT_DIR} = $path->dirname;
134             }
135              
136 5         57 $self->{SCRIPT_PATH} = $self->{SCRIPT_DIR} . $self->{SCRIPT_NAME};
137              
138 5         193 $self->{SYS_TEMP_DIR} = P->path( File::Spec->tmpdir, is_dir => 1 )->to_string;
139 5         127 $self->{TEMP_DIR} = P->file->tempdir( base => $self->{SYS_TEMP_DIR}, lazy => 1 );
140 5   33     130 $self->{USER_DIR} = P->path( $ENV{HOME} || $ENV{USERPROFILE}, is_dir => 1 );
141 5         34 $self->{PCORE_USER_DIR} = P->path( $self->{USER_DIR} . '.pcore/', is_dir => 1, lazy => 1 );
142 5         106 $self->{PCORE_SYS_DIR} = P->path( $self->{SYS_TEMP_DIR} . '.pcore/', is_dir => 1, lazy => 1 );
143 5 50       118 $self->{INLINE_DIR} = $self->is_par ? undef : P->path( $self->{PCORE_USER_DIR} . "inline/$Config{version}/$Config{archname}/", is_dir => 1, lazy => 1 );
144              
145             # CLI options
146 5         21 $self->{SCAN_DEPS} = 0;
147 5         14 $self->{DAEMONIZE} = 0;
148 5         13 $self->{UID} = undef;
149 5         14 $self->{GID} = undef;
150              
151             # load dist.perl
152 5 50       21 if ( my $dist = $self->dist ) {
153 5 50       155 if ( $self->is_par ) {
154 0         0 $self->{DATA_DIR} = $self->{SCRIPT_DIR};
155             }
156             else {
157 5         161 $self->{DATA_DIR} = P->path( $dist->root . 'data/', is_dir => 1, lazy => 1 );
158             }
159             }
160             else {
161 0         0 $self->{DATA_DIR} = $self->{START_DIR};
162             }
163              
164             # init pcore dist, needed to register pcore resources during bootstrap
165 5         139 $self->pcore;
166              
167 5         142 return;
168             }
169              
170 5     5   62 sub _build_is_par ($self) {
  5         12  
  5         10  
171 5 50       87 return $ENV{PAR_TEMP} ? 1 : 0;
172             }
173              
174 5     5   56 sub _build__main_dist ($self) {
  5         10  
  5         6  
175 5         10 my $dist;
176              
177 5 50       81 if ( $self->is_par ) {
178 0         0 $dist = Pcore::Dist->new( $ENV{PAR_TEMP} );
179             }
180             else {
181 5         146 $dist = Pcore::Dist->new( $self->{SCRIPT_DIR} );
182             }
183              
184 5 50       385 if ($dist) {
185 5         14 $dist->{is_main} = 1;
186              
187 5         21 $self->register_dist($dist);
188             }
189              
190 5         70 return $dist;
191             }
192              
193 5     5   59 sub _build_pcore ($self) {
  5         11  
  5         10  
194 5 50 33     20 if ( $self->dist && $self->dist->is_pcore ) {
195 5         129 return $self->dist;
196             }
197             else {
198 0         0 my $pcore = Pcore::Dist->new('Pcore.pm');
199              
200 0         0 $self->register_dist($pcore);
201              
202 0         0 return $pcore;
203             }
204             }
205              
206 5     5   53 sub _build_share ($self) {
  5         12  
  5         6  
207 5         47 return Pcore::Core::Env::Share->new;
208             }
209              
210 0     0   0 sub _build_user_cfg_path ($self) {
  0         0  
  0         0  
211 0         0 return "$self->{PCORE_USER_DIR}pcore.ini";
212             }
213              
214 0     0   0 sub _build_user_cfg ($self) {
  0         0  
  0         0  
215 0 0       0 if ( !-f $self->user_cfg_path ) {
216 0         0 return {};
217             }
218             else {
219 0         0 return P->cfg->load( $self->user_cfg_path );
220             }
221             }
222              
223 5     5 0 9 sub register_dist ( $self, $dist ) {
  5         14  
  5         9  
  5         11  
224              
225             # create dist object
226 5 50       18 $dist = Pcore::Dist->new($dist) if !ref $dist;
227              
228             # dist was not found
229 5 50       14 die qq[Invlaid Pcore -dist pragma usage, "$dist" is not a Pcore dist main module] if !$dist;
230              
231             # dist is already registered
232 5 50       95 return if exists $self->_dist_idx->{ $dist->name };
233              
234             # add dist to the dists index
235 5         243 $self->_dist_idx->{ $dist->name } = $dist;
236              
237             # register dist share
238 5         133 my $share_lib_level;
239              
240 5 50       104 if ( $dist->is_pcore ) { # pcore dist is always first
    0          
241 5         143 $share_lib_level = 0;
242             }
243             elsif ( $dist->is_main ) { # main dist is always on top
244 0         0 $share_lib_level = 9_999;
245              
246             }
247             else {
248 0         0 state $next_level = 10;
249              
250 0         0 $share_lib_level = $next_level++;
251             }
252              
253 5         77 $self->share->add_lib( $dist->name, $dist->share_dir, $share_lib_level );
254              
255 5         12 return;
256             }
257              
258 50     50 0 375 sub dist ( $self, $dist_name = undef ) {
  50         101  
  50         68  
  50         63  
259 50 50       94 if ($dist_name) {
260 0         0 return $self->_dist_idx->{ $dist_name =~ s/::/-/smgr };
261             }
262             else {
263 50         788 return $self->_main_dist;
264             }
265             }
266              
267             # SCAN DEPS
268 5     5   82 sub _build_can_scan_deps ($self) {
  5         13  
  5         13  
269 5   33     97 return !$self->is_par && $self->dist && $self->dist->par_cfg && exists $self->dist->par_cfg->{ $self->{SCRIPT_NAME} };
270             }
271              
272 0     0 0   sub scan_deps ($self) {
  0            
  0            
273 0 0         return if !$self->can_scan_deps;
274              
275 0           $self->{SCAN_DEPS} = $self->dist->share_dir . "pardeps-$self->{SCRIPT_NAME}-@{[$^V->normal]}-$Config{archname}.json";
  0            
276              
277             # eval TypeTiny Error
278 0           eval { Int->('error') };
  0            
279              
280             # eval common modules
281 0           require Cpanel::JSON::XS; ## no critic qw[Modules::ProhibitEvilModules]
282              
283 0           return;
284             }
285              
286 0     0 0   sub DEMOLISH ( $self, $global ) {
  0            
  0            
  0            
287 0 0         if ( $self->{SCAN_DEPS} ) {
288 0           my ( $fh, $index );
289              
290 0 0         if ( -f $self->{SCAN_DEPS} ) {
291 0 0         open $fh, '+<:raw', $self->{SCAN_DEPS} or die; ## no critic qw[InputOutput::RequireBriefOpen]
292              
293 0 0         flock $fh, LOCK_EX or die;
294              
295 0           local $/;
296              
297 0           my $deps = Cpanel::JSON::XS->new->ascii(0)->latin1(0)->utf8(1)->pretty(1)->canonical(1)->decode(<$fh>);
298              
299 0           $index->@{ $deps->@* } = ();
300             }
301             else {
302 0 0         open $fh, '>:raw', $self->{SCAN_DEPS} or die; ## no critic qw[InputOutput::RequireBriefOpen]
303              
304 0 0         flock $fh, LOCK_EX or die;
305             }
306              
307 0           my ( $updated, $embedded_packages );
308              
309 0           for my $module ( sort keys %INC ) {
310 0 0         if ( !exists $index->{$module} ) {
311 0 0         if ( $INC{$module} !~ /\Q$module\E\z/sm ) {
312 0           $embedded_packages->{$module} = $INC{$module};
313             }
314             else {
315 0           $updated = 1;
316              
317 0           $index->{$module} = undef;
318              
319 0           say qq[new deps found: $module];
320             }
321             }
322             }
323              
324             # find real module for embedded modules
325 0 0         if ($embedded_packages) {
326 0           for my $embedded_package ( keys $embedded_packages->%* ) {
327 0           my $added;
328              
329 0           for my $module ( keys %INC ) {
330 0 0         if ( $INC{$module} eq $embedded_packages->{$embedded_package} ) {
331              
332             # embedded package is already added
333 0 0         if ( exists $index->{$module} ) {
334              
335             # say "$module ---> $embedded_package";
336              
337 0           $added = 1;
338              
339 0           last;
340             }
341             }
342             }
343              
344 0 0         if ( !$added ) {
345 0           $updated = 1;
346              
347 0           $index->{$embedded_package} = undef;
348              
349 0           say qq[new deps found: $embedded_package];
350             }
351             }
352             }
353              
354             # store deps
355 0 0         if ($updated) {
356 0 0         truncate $fh, 0 or die;
357              
358 0 0         seek $fh, 0, SEEK_SET or die;
359              
360 0           print {$fh} Cpanel::JSON::XS->new->ascii(0)->latin1(0)->utf8(1)->pretty(1)->canonical(1)->encode( [ sort keys $index->%* ] );
  0            
361             }
362              
363 0 0         close $fh or die;
364             }
365              
366 0           return;
367             }
368              
369             1;
370             ## -----SOURCE FILTER LOG BEGIN-----
371             ##
372             ## PerlCritic profile "pcore-script" policy violations:
373             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
374             ## | Sev. | Lines | Policy |
375             ## |======+======================+================================================================================================================|
376             ## | 3 | 278 | ErrorHandling::RequireCheckingReturnValueOfEval - Return value of eval not tested |
377             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
378             ## | 3 | 286 | Subroutines::ProhibitExcessComplexity - Subroutine "DEMOLISH" with high complexity score (22) |
379             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
380             ## | 3 | 295 | Variables::RequireInitializationForLocalVars - "local" variable not initialized |
381             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
382             ## | 3 | 333 | ControlStructures::ProhibitDeepNests - Code structure is deeply nested |
383             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
384             ## | 2 | 297, 360 | ValuesAndExpressions::ProhibitLongChainsOfMethodCalls - Found method-call chain of length 7 |
385             ## |------+----------------------+----------------------------------------------------------------------------------------------------------------|
386             ## | 1 | 101 | BuiltinFunctions::ProhibitReverseSortBlock - Forbid $b before $a in sort blocks |
387             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
388             ##
389             ## -----SOURCE FILTER LOG END-----
390             __END__
391             =pod
392              
393             =encoding utf8
394              
395             =head1 NAME
396              
397             Pcore::Core::Env
398              
399             =head1 SYNOPSIS
400              
401             =head1 DESCRIPTION
402              
403             =head1 ATTRIBUTES
404              
405             =head1 METHODS
406              
407             =head1 SEE ALSO
408              
409             =cut