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   32 use Pcore -class;
  5         13  
  5         34  
4 5     5   46 use Config;
  5         11  
  5         1274  
5 5     5   1225 use File::Spec qw[]; ## no critic qw[Modules::ProhibitEvilModules] needed to find system temp dir
  5         11  
  5         96  
6 5     5   27 use Cwd qw[]; ## no critic qw[Modules::ProhibitEvilModules]
  5         11  
  5         894  
7 5     5   1851 use Pcore::Dist;
  5         17  
  5         179  
8 5     5   1923 use Pcore::Core::Env::Share;
  5         15  
  5         190  
9 5     5   34 use Fcntl qw[LOCK_EX SEEK_SET];
  5         10  
  5         14416  
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   14 my @inc;
33              
34             my $inc_index;
35              
36             # index @INC, resolve @INC paths, remove duplicates, preserve REF items
37 5         15 for my $inc_path (@INC) {
38 50 50       113 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       632 next if !-d $inc_path;
46              
47 50         887 $inc_path = P->path( $inc_path, is_dir => 1 )->realpath->canonpath;
48              
49             # ignore already added path
50 50 100       483 if ( !exists $inc_index->{$inc_path} ) {
51 40         95 $inc_index->{$inc_path} = 1;
52              
53 40         100 push @inc, $inc_path;
54             }
55             }
56              
57 5         28 @INC = @inc; ## no critic qw[Variables::RequireLocalizedPunctuationVars]
58              
59 5         20 return;
60             }
61              
62             sub _configure_inc {
63 5     5   13 my @inc;
64              
65             my $inc_index;
66              
67             # index @INC, resolve @INC paths, remove duplicates, preserve REF items
68 5         15 for my $inc_path (@INC) {
69 40 50       70 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       74 if ( !exists $inc_index->{$inc_path} ) {
77 40         81 $inc_index->{$inc_path} = 1;
78              
79 40         76 push @inc, $inc_path;
80             }
81             }
82              
83             # not for PAR
84 5 50       89 if ( !$ENV->is_par ) {
85 5         46 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       19 if ( !$is_module_build_test ) {
90 5         9 my $dist_lib_path;
91              
92             # detect dist lib path
93 5 50 33     15 if ( $ENV->dist && !exists $inc_index->{ $ENV->dist->root . 'lib' } && -d $ENV->dist->root . 'lib/' ) {
      33        
94 5         140 $dist_lib_path = $ENV->dist->root . 'lib';
95              
96 5         51 $inc_index->{$dist_lib_path} = 1;
97             }
98              
99             # find and add other dist libs to @INC
100 5 50 33     29 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       25 unshift @inc, $dist_lib_path if $dist_lib_path;
112             }
113             }
114              
115 5         25 @INC = @inc; ## no critic qw[Variables::RequireLocalizedPunctuationVars]
116              
117 5         20 return;
118             }
119              
120 5     5   13 sub _INIT ($self) {
  5         11  
  5         12  
121 5         58 $self->{START_DIR} = P->file->cwd->to_string;
122              
123 5 50 33     42 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       89 die qq[Cannot find current script "$Pcore::SCRIPT_PATH"] if !-f $Pcore::SCRIPT_PATH;
129              
130 5         100 my $path = P->path($Pcore::SCRIPT_PATH)->realpath;
131              
132 5         122 $self->{SCRIPT_NAME} = $path->filename;
133 5         140 $self->{SCRIPT_DIR} = $path->dirname;
134             }
135              
136 5         62 $self->{SCRIPT_PATH} = $self->{SCRIPT_DIR} . $self->{SCRIPT_NAME};
137              
138 5         209 $self->{SYS_TEMP_DIR} = P->path( File::Spec->tmpdir, is_dir => 1 )->to_string;
139 5         128 $self->{TEMP_DIR} = P->file->tempdir( base => $self->{SYS_TEMP_DIR}, lazy => 1 );
140 5   33     133 $self->{USER_DIR} = P->path( $ENV{HOME} || $ENV{USERPROFILE}, is_dir => 1 );
141 5         37 $self->{PCORE_USER_DIR} = P->path( $self->{USER_DIR} . '.pcore/', is_dir => 1, lazy => 1 );
142 5         102 $self->{PCORE_SYS_DIR} = P->path( $self->{SYS_TEMP_DIR} . '.pcore/', is_dir => 1, lazy => 1 );
143 5 50       126 $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         12 $self->{UID} = undef;
149 5         13 $self->{GID} = undef;
150              
151             # load dist.perl
152 5 50       22 if ( my $dist = $self->dist ) {
153 5 50       191 if ( $self->is_par ) {
154 0         0 $self->{DATA_DIR} = $self->{SCRIPT_DIR};
155             }
156             else {
157 5         178 $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         110 $self->pcore;
166              
167 5         130 return;
168             }
169              
170 5     5   69 sub _build_is_par ($self) {
  5         14  
  5         9  
171 5 50       94 return $ENV{PAR_TEMP} ? 1 : 0;
172             }
173              
174 5     5   58 sub _build__main_dist ($self) {
  5         10  
  5         9  
175 5         8 my $dist;
176              
177 5 50       98 if ( $self->is_par ) {
178 0         0 $dist = Pcore::Dist->new( $ENV{PAR_TEMP} );
179             }
180             else {
181 5         145 $dist = Pcore::Dist->new( $self->{SCRIPT_DIR} );
182             }
183              
184 5 50       425 if ($dist) {
185 5         14 $dist->{is_main} = 1;
186              
187 5         26 $self->register_dist($dist);
188             }
189              
190 5         78 return $dist;
191             }
192              
193 5     5   64 sub _build_pcore ($self) {
  5         12  
  5         9  
194 5 50 33     20 if ( $self->dist && $self->dist->is_pcore ) {
195 5         159 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   59 sub _build_share ($self) {
  5         9  
  5         10  
207 5         49 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 10 sub register_dist ( $self, $dist ) {
  5         10  
  5         8  
  5         19  
224              
225             # create dist object
226 5 50       16 $dist = Pcore::Dist->new($dist) if !ref $dist;
227              
228             # dist was not found
229 5 50       17 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       103 return if exists $self->_dist_idx->{ $dist->name };
233              
234             # add dist to the dists index
235 5         295 $self->_dist_idx->{ $dist->name } = $dist;
236              
237             # register dist share
238 5         150 my $share_lib_level;
239              
240 5 50       87 if ( $dist->is_pcore ) { # pcore dist is always first
    0          
241 5         141 $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         85 $self->share->add_lib( $dist->name, $dist->share_dir, $share_lib_level );
254              
255 5         15 return;
256             }
257              
258 50     50 0 385 sub dist ( $self, $dist_name = undef ) {
  50         101  
  50         77  
  50         58  
259 50 50       92 if ($dist_name) {
260 0         0 return $self->_dist_idx->{ $dist_name =~ s/::/-/smgr };
261             }
262             else {
263 50         810 return $self->_main_dist;
264             }
265             }
266              
267             # SCAN DEPS
268 5     5   82 sub _build_can_scan_deps ($self) {
  5         9  
  5         8  
269 5   33     92 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