File Coverage

blib/lib/Pcore/Dist.pm
Criterion Covered Total %
statement 39 133 29.3
branch 7 54 12.9
condition 0 33 0.0
subroutine 8 19 42.1
pod 0 4 0.0
total 54 243 22.2


line stmt bran cond sub pod time code
1             package Pcore::Dist;
2              
3 5     5   30 use Pcore -class;
  5         9  
  5         31  
4 5     5   42 use Config;
  5         239  
  5         14395  
5              
6             has root => ( is => 'ro', isa => Maybe [Str], required => 1 ); # absolute path to the dist root
7             has is_cpan_dist => ( is => 'ro', isa => Bool, required => 1 ); # dist is installed as CPAN module, root is undefined
8             has share_dir => ( is => 'ro', isa => Str, required => 1 ); # absolute path to the dist share dir
9              
10             has module => ( is => 'lazy', isa => InstanceOf ['Pcore::Util::Perl::Module'], predicate => 1 );
11              
12             has cfg => ( is => 'lazy', isa => HashRef, clearer => 1, init_arg => undef ); # dist.perl
13             has docker_cfg => ( is => 'lazy', isa => Maybe [HashRef], clearer => 1, init_arg => undef ); # docker.json
14             has par_cfg => ( is => 'lazy', isa => Maybe [HashRef], init_arg => undef ); # par.ini
15             has name => ( is => 'lazy', isa => Str, init_arg => undef ); # Dist-Name
16             has is_pcore => ( is => 'lazy', isa => Bool, init_arg => undef );
17             has is_main => ( is => 'ro', isa => Bool, default => 0, init_arg => undef ); # main process dist
18             has scm => ( is => 'lazy', isa => Maybe [ ConsumerOf ['Pcore::API::SCM'] ], init_arg => undef );
19             has build => ( is => 'lazy', isa => InstanceOf ['Pcore::Dist::Build'], init_arg => undef );
20             has id => ( is => 'lazy', isa => HashRef, clearer => 1, init_arg => undef );
21             has version => ( is => 'lazy', isa => Object, clearer => 1, init_arg => undef );
22             has is_commited => ( is => 'lazy', isa => Maybe [Bool], init_arg => undef );
23             has releases => ( is => 'lazy', isa => Maybe [ArrayRef], init_arg => undef );
24             has docker => ( is => 'lazy', isa => Maybe [HashRef], clearer => 1, init_arg => undef );
25              
26             around new => sub ( $orig, $self, $dist ) {
27              
28             # PAR dist processing
29             if ( $ENV{PAR_TEMP} && $dist eq $ENV{PAR_TEMP} ) {
30              
31             # dist is the PAR dist
32             return $self->$orig(
33             { root => undef,
34             is_cpan_dist => 1,
35             share_dir => P->path( $ENV{PAR_TEMP} . '/inc/share/' )->to_string,
36             }
37             );
38             }
39              
40             my $module_name;
41              
42             if ( substr( $dist, -3, 3 ) eq '.pm' ) {
43              
44             # if $dist contain .pm suffix - this is a full or related module name
45             $module_name = $dist;
46             }
47             elsif ( $dist =~ m[[./\\]]sm ) {
48              
49             # if $dist doesn't contain .pm suffix, but contain ".", "/" or "\" - this is a path
50             # try find dist by path
51             if ( my $root = $self->find_dist_root($dist) ) {
52              
53             # path is a part of the dist
54             return $self->$orig(
55             { root => $root->to_string,
56             is_cpan_dist => 0,
57             share_dir => $root . 'share/',
58             }
59             );
60             }
61             else {
62              
63             # path is NOT a part of a dist
64             return;
65             }
66             }
67             else {
68              
69             # otherwise $dist is a Package::Name
70             $module_name = $dist =~ s[(?:::|-)][/]smgr . '.pm';
71             }
72              
73             # find dist by module name
74             my $module_lib;
75              
76             # find full module path
77             if ( $module_lib = $INC{$module_name} ) {
78              
79             # if module is already loaded - get full module path from %INC
80             # cut module name, throw error in case, where: 'Module/Name.pm' => '/path/to/Other/Module.pm'
81             die q[Invalid module name in %INC, please report] if $module_lib !~ s[[/\\]\Q$module_name\E\z][]sm;
82             }
83             else {
84              
85             # or try to find module in @INC
86             for my $inc (@INC) {
87             next if ref $inc;
88              
89             if ( -f "$inc/$module_name" ) {
90             $module_lib = $inc;
91              
92             last;
93             }
94             }
95             }
96              
97             # module was not found in @INC
98             return if !$module_lib;
99              
100             # normalize module lib
101             $module_lib = P->path( $module_lib, is_dir => 1 )->to_string;
102              
103             # convert Module/Name.pm to Dist-Name
104             my $dist_name = $module_name =~ s[/][-]smgr;
105              
106             # remove .pm suffix
107             substr $dist_name, -3, 3, q[];
108              
109             if ( -f $module_lib . "auto/share/dist/$dist_name/dist.perl" ) {
110              
111             # module is installed
112             return $self->$orig(
113             { root => undef,
114             is_cpan_dist => 1,
115             share_dir => $module_lib . "auto/share/dist/$dist_name/",
116             module => P->perl->module( $module_name, $module_lib ),
117             }
118             );
119             }
120             elsif ( $self->dir_is_dist_root("$module_lib/../") ) {
121             my $root = P->path("$module_lib/../")->to_string;
122              
123             # module is a dist
124             return $self->$orig(
125             { root => $root,
126             is_cpan_dist => 0,
127             share_dir => $root . 'share/',
128             module => P->perl->module( $module_name, $module_lib ),
129             }
130             );
131             }
132              
133             return;
134             };
135              
136             # CLASS METHODS
137 5     5 0 15 sub find_dist_root ( $self, $path ) {
  5         10  
  5         10  
  5         8  
138 5 50       95 $path = P->path( $path, is_dir => 1 ) if !ref $path;
139              
140 5 50       27 if ( !$self->dir_is_dist_root($path) ) {
141 5         23 $path = $path->parent;
142              
143 5         24 while ($path) {
144 5 50       46 last if $self->dir_is_dist_root($path);
145              
146 0         0 $path = $path->parent;
147             }
148             }
149              
150 5 50       125 if ( defined $path ) {
151 5         25 return $path->realpath;
152             }
153             else {
154 0         0 return;
155             }
156             }
157              
158 10     10 0 21 sub dir_is_dist_root ( $self, $path ) {
  10         18  
  10         16  
  10         17  
159 10 100       37 return -f $path . '/share/dist.perl' ? 1 : 0;
160             }
161              
162             # BUILDERS
163 0     0   0 sub _build_module ($self) {
  0         0  
  0         0  
164 0         0 my $module_name = $self->name =~ s[-][/]smgr . '.pm';
165              
166 0         0 my $module;
167              
168 0 0       0 if ( $self->is_cpan_dist ) {
    0          
169              
170             # find main module in @INC
171 0         0 $module = P->perl->module($module_name);
172             }
173             elsif ( -f $self->root . 'lib/' . $module_name ) {
174              
175             # we check -f manually, because perl->module will search for Module/Name.pm in whole @INC, but we need only to search module in dist root
176             # get main module from dist root lib
177 0         0 $module = P->perl->module( $module_name, $self->root . 'lib/' );
178             }
179              
180 0 0       0 die qq[Distr main module "$module_name" wasn't found, distribution is corrupted] if !$module;
181              
182 0         0 return $module;
183             }
184              
185 5     5   53 sub _build_cfg ($self) {
  5         9  
  5         12  
186 5         54 return P->cfg->load( $self->share_dir . 'dist.perl' );
187             }
188              
189 0     0   0 sub _build_docker_cfg ($self) {
  0         0  
  0         0  
190 0 0       0 if ( -f $self->share_dir . 'docker.json' ) {
191 0         0 return P->cfg->load( $self->share_dir . 'docker.json' );
192             }
193              
194 0         0 return;
195             }
196              
197 5     5   185 sub _build_par_cfg ($self) {
  5         12  
  5         10  
198 5 50       131 if ( -f $self->share_dir . 'par.ini' ) {
199 0         0 return P->cfg->load( $self->share_dir . 'par.ini' );
200             }
201              
202 5         85 return;
203             }
204              
205 5     5   163 sub _build_name ($self) {
  5         10  
  5         8  
206 5         89 return $self->cfg->{name};
207             }
208              
209 5     5   61 sub _build_is_pcore ($self) {
  5         9  
  5         7  
210 5         74 return $self->name eq 'Pcore';
211             }
212              
213 0     0     sub _build_scm ($self) {
  0            
  0            
214 0 0         return if $self->is_cpan_dist;
215              
216 0           return P->class->load('Pcore::API::SCM')->new( $self->root );
217             }
218              
219 0     0     sub _build_build ($self) {
  0            
  0            
220 0           return P->class->load('Pcore::Dist::Build')->new( { dist => $self } );
221             }
222              
223 0     0     sub _build_id ($self) {
  0            
  0            
224 0           my $id = {
225             node => undef,
226             phase => undef,
227             tags => undef,
228             bookmark => undef,
229             branch => undef,
230             desc => undef,
231             date => undef,
232             release => undef,
233             release_distance => undef,
234             };
235              
236 0 0 0       if ( !$self->is_cpan_dist && $self->scm ) {
    0          
237 0 0         if ( my $scm_id = $self->scm->scm_id ) {
238 0           $id->@{ keys $scm_id->{data}->%* } = values $scm_id->{data}->%*;
239             }
240              
241 0 0 0       if ( $id->{release} && defined $id->{release_distance} && $id->{release_distance} == 1 ) {
      0        
242 0 0         $id->{release_distance} = 0 if $id->{desc} =~ /added tag.+$id->{release}/smi;
243             }
244             }
245             elsif ( -f $self->share_dir . 'dist-id.json' ) {
246 0           $id = P->cfg->load( $self->share_dir . 'dist-id.json' );
247             }
248              
249             # convert date to UTC
250 0 0         $id->{date} = P->date->from_string( $id->{date} )->at_utc->to_string if defined $id->{date};
251              
252 0   0       $id->{release} //= 'v0.0.0';
253              
254 0           $id->{release_id} = $id->{release};
255              
256 0 0         $id->{release_id} .= "+$id->{release_distance}" if $id->{release_distance};
257              
258 0           return $id;
259             }
260              
261 0     0     sub _build_version ($self) {
  0            
  0            
262              
263             # first, try to get version from the main module
264 0           my $ver = $self->module->version;
265              
266 0 0         return $ver if defined $ver;
267              
268             # for crypted PAR distrs try to get version from id
269 0           return version->parse( $self->id->{release} );
270             }
271              
272 0     0     sub _build_is_commited ($self) {
  0            
  0            
273 0 0 0       if ( !$self->is_cpan_dist && $self->scm && ( my $scm_is_commited = $self->scm->scm_is_commited ) ) {
      0        
274 0           return $scm_is_commited->{data};
275             }
276              
277 0           return;
278             }
279              
280 0     0     sub _build_releases ($self) {
  0            
  0            
281 0 0 0       if ( !$self->is_cpan_dist && $self->scm && ( my $scm_releases = $self->scm->scm_releases ) ) {
      0        
282 0           return $scm_releases->{data};
283             }
284              
285 0           return;
286             }
287              
288 0     0 0   sub clear ($self) {
  0            
  0            
289              
290             # clear version
291 0 0         $self->module->clear if $self->has_module;
292              
293 0           $self->clear_version;
294              
295 0           $self->clear_id;
296              
297 0           $self->clear_cfg;
298              
299 0           $self->clear_docker_cfg;
300              
301 0           $self->clear_docker;
302              
303 0           return;
304             }
305              
306 0     0 0   sub version_string ($self) {
  0            
  0            
307 0           my $is_commited = $self->is_commited;
308              
309 0   0       $is_commited //= 1;
310              
311 0 0         my @tags = $self->id->{tags} ? $self->id->{tags}->@* : ();
312              
313 0 0         return join q[ ], $self->name, $self->id->{release_id}, join( q[ ], grep {$_} $self->id->{branch}, $self->id->{bookmark}, sort @tags ), $self->id->{node} . ( $is_commited ? q[] : q[+] ), $self->id->{date};
  0            
314             }
315              
316 0     0     sub _build_docker ($self) {
  0            
  0            
317 0 0 0       if ( $self->docker_cfg && -f $self->root . 'Dockerfile' ) {
318             my $docker = {
319             repo_namespace => $self->docker_cfg->{repo_namespace},
320             repo_name => $self->docker_cfg->{repo_name},
321 0           repo_id => undef,
322             from => undef,
323             from_repo_id => undef,
324             from_tag => undef,
325             };
326              
327 0 0 0       return if !$docker->{repo_namespace} || !$docker->{repo_name};
328              
329 0           $docker->{repo_id} = "$docker->{repo_namespace}/$docker->{repo_name}";
330              
331 0           my $dockerfile = P->file->read_bin( $self->root . 'Dockerfile' );
332              
333 0 0         if ( $dockerfile->$* =~ /^FROM\s+([^:]+):?(.*?)$/sm ) {
334 0           $docker->{from_repo_id} = $1;
335              
336 0   0       $docker->{from_tag} = $2 // 'latest';
337              
338 0           $docker->{from} = "$docker->{from_repo_id}:$docker->{from_tag}";
339              
340 0           return $docker;
341             }
342             else {
343 0           die q[Error parsing "FROM" command in Dockerfile];
344             }
345             }
346             else {
347 0           return;
348             }
349             }
350              
351             1;
352             ## -----SOURCE FILTER LOG BEGIN-----
353             ##
354             ## PerlCritic profile "pcore-script" policy violations:
355             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
356             ## | Sev. | Lines | Policy |
357             ## |======+======================+================================================================================================================|
358             ## | 3 | 109, 159 | ValuesAndExpressions::ProhibitMismatchedOperators - Mismatched operator |
359             ## +------+----------------------+----------------------------------------------------------------------------------------------------------------+
360             ##
361             ## -----SOURCE FILTER LOG END-----
362             __END__
363             =pod
364              
365             =encoding utf8
366              
367             =head1 NAME
368              
369             Pcore::Dist
370              
371             =head1 SYNOPSIS
372              
373             =head1 DESCRIPTION
374              
375             =head1 ATTRIBUTES
376              
377             =head1 METHODS
378              
379             =head1 SEE ALSO
380              
381             =cut