File Coverage

lib/Module/Provision/Base.pm
Criterion Covered Total %
statement 51 138 36.9
branch 0 52 0.0
condition 0 22 0.0
subroutine 20 47 42.5
pod 3 3 100.0
total 74 262 28.2


line stmt bran cond sub pod time code
1             package Module::Provision::Base;
2              
3 1     1   465 use namespace::autoclean;
  1         3  
  1         6  
4              
5 1     1   491 use Class::Usul::Constants qw( EXCEPTION_CLASS NUL SPC TRUE );
  1         9176  
  1         7  
6 1         7 use Class::Usul::Functions qw( app_prefix class2appdir classdir
7 1     1   1237 distname first_char io is_arrayref throw );
  1         44969  
8 1     1   1894 use Class::Usul::Time qw( time2str );
  1         11188  
  1         53  
9 1     1   450 use CPAN::Meta;
  1         20572  
  1         33  
10 1     1   8 use English qw( -no_match_vars );
  1         2  
  1         8  
11 1         15 use File::DataClass::Types qw( ArrayRef Directory HashRef NonEmptySimpleStr
12             Object OctalNum Path PositiveInt
13 1     1   773 SimpleStr Undef );
  1         35406  
14 1     1   2021 use Module::Metadata;
  1         2  
  1         19  
15 1     1   535 use Perl::Version;
  1         2213  
  1         32  
16 1     1   6 use Try::Tiny;
  1         3  
  1         55  
17 1     1   6 use Type::Utils qw( enum );
  1         1  
  1         7  
18 1     1   505 use Unexpected::Functions qw( Unspecified );
  1         3  
  1         10  
19 1     1   288 use Moo;
  1         3  
  1         8  
20 1     1   854 use Class::Usul::Options;
  1         2443  
  1         6  
21              
22             extends q(Class::Usul::Programs);
23              
24             my %BUILDERS = ( 'DZ' => 'dist.ini', 'MB' => 'Build.PL', );
25             my $BUILDER = enum 'Builder' => [ qw( DZ MB ) ];
26             my $VCS = enum 'VCS' => [ qw( git none svn ) ];
27              
28             # Override defaults in base class
29             has '+config_class' => default => sub { 'Module::Provision::Config' };
30              
31             # Object attributes (public)
32             # Visible to the command line
33             option 'base' => is => 'lazy', isa => Path, format => 's',
34             documentation => 'Directory containing new projects',
35 0     0   0 builder => sub { $_[ 0 ]->config->base }, coerce => TRUE;
36              
37             option 'branch' => is => 'lazy', isa => SimpleStr, format => 's',
38             documentation => 'The name of the initial branch to create', short => 'b';
39              
40             option 'builder' => is => 'lazy', isa => $BUILDER, format => 's',
41             documentation => 'Which build system to use: DZ or MB';
42              
43             option 'license' => is => 'ro', isa => NonEmptySimpleStr, format => 's',
44             documentation => 'License used for the project',
45 1     1   1973 builder => sub { $_[ 0 ]->config->license };
46              
47             option 'perms' => is => 'ro', isa => OctalNum, format => 'i',
48             documentation => 'Default permission for file / directory creation',
49             default => '640', coerce => TRUE;
50              
51             option 'plugins' => is => 'ro', isa => ArrayRef[NonEmptySimpleStr],
52             documentation => 'Name of optional plugins to load, comma separated list',
53 1     1   29680 builder => sub { [] }, format => 's', short => 'M',
54             coerce => sub { (is_arrayref $_[ 0 ])
55             ? $_[ 0 ] : [ split m{ , }mx, $_[ 0 ] ] };
56              
57             option 'project' => is => 'lazy', isa => NonEmptySimpleStr, format => 's',
58             documentation => 'Package name of the new projects main module';
59              
60             option 'repository' => is => 'ro', isa => NonEmptySimpleStr, format => 's',
61             documentation => 'Directory containing the SVN repository',
62 1     1   142 builder => sub { $_[ 0 ]->config->repository };
63              
64             option 'vcs' => is => 'lazy', isa => $VCS, format => 's',
65             documentation => 'Which VCS to use: git, none, or svn';
66              
67             # Ingnored by the command line
68             has 'appbase' => is => 'lazy', isa => Path, coerce => TRUE;
69              
70             has 'appldir' => is => 'lazy', isa => Path, coerce => TRUE;
71              
72             has 'branch_file' => is => 'lazy', isa => Path, coerce => TRUE,
73 0     0   0 builder => sub { [ $_[ 0 ]->appbase, '.branch' ] };
74              
75             has 'binsdir' => is => 'lazy', isa => Path, coerce => TRUE,
76 0     0   0 builder => sub { [ $_[ 0 ]->appldir, 'bin' ] };
77              
78             has 'default_branch' => is => 'lazy', isa => SimpleStr;
79              
80             has 'dist_module' => is => 'lazy', isa => Path, coerce => TRUE,
81 0     0   0 builder => sub { [ $_[ 0 ]->homedir.'.pm' ] };
82              
83             has 'dist_version' => is => 'lazy', isa => Object, clearer => TRUE;
84              
85             has 'distname' => is => 'lazy', isa => NonEmptySimpleStr,
86 0     0   0 builder => sub { distname $_[ 0 ]->project };
87              
88             has 'exec_perms' => is => 'lazy', isa => PositiveInt;
89              
90             has 'homedir' => is => 'lazy', isa => Path, coerce => TRUE;
91              
92             has 'incdir' => is => 'lazy', isa => Path, coerce => TRUE,
93 0     0   0 builder => sub { [ $_[ 0 ]->appldir, 'inc' ] };
94              
95             has 'initial_wd' => is => 'ro', isa => Directory,
96 1     1   189 builder => sub { io()->cwd };
97              
98             has 'libdir' => is => 'lazy', isa => Path, coerce => TRUE,
99 0     0   0 builder => sub { [ $_[ 0 ]->appldir, 'lib' ] };
100              
101             has 'license_keys' => is => 'lazy', isa => HashRef;
102              
103             has 'manifest_paths' => is => 'lazy', isa => ArrayRef, init_arg => undef;
104              
105             has 'module_abstract' => is => 'lazy', isa => NonEmptySimpleStr;
106              
107             has 'module_metadata' => is => 'lazy', isa => Object | Undef, builder => sub {
108 0     0   0 Module::Metadata->new_from_file
109             ( $_[ 0 ]->dist_module->abs2rel( $_[ 0 ]->appldir ), collect_pod => 1 ) },
110             clearer => TRUE;
111              
112             has 'project_file' => is => 'lazy', isa => NonEmptySimpleStr;
113              
114             has 'stash' => is => 'lazy', isa => HashRef;
115              
116             has 'testdir' => is => 'lazy', isa => Path, coerce => TRUE,
117 0     0   0 builder => sub { [ $_[ 0 ]->appldir, 't' ] };
118              
119             # Private functions
120             my $_builders = sub {
121             return (sort keys %BUILDERS);
122             };
123              
124             my $_get_module_from = sub { # Return main module name from project file
125             return
126             (map { s{ [-] }{::}gmx; $_ }
127             map { m{ \A [q\'\"] }mx ? eval $_ : $_ }
128             map { m{ \A \s* (?:module_name|module|name)
129             \s+ [=]?[>]? \s* ([^,;]+) [,;]? }imx }
130             grep { m{ \A \s* (module|name) }imx }
131             split m{ [\n] }mx, $_[ 0 ])[ 0 ];
132             };
133              
134             my $_parse_manifest_line = sub { # Robbed from ExtUtils::Manifest
135             my $line = shift; my ($file, $comment);
136              
137             # May contain spaces if enclosed in '' (in which case, \\ and \' are escapes)
138             if (($file, $comment) = $line =~ m{ \A \' (\\[\\\']|.+)+ \' \s* (.*) }mx) {
139             $file =~ s{ \\ ([\\\']) }{$1}gmx;
140             }
141             else {
142             ($file, $comment) = $line =~ m{ \A (\S+) \s* (.*) }mx;
143             }
144              
145             return [ $file, $comment ];
146             };
147              
148             my $_get_project_file = sub {
149             my $dir = shift; my $prev;
150              
151             while (not $prev or $prev ne $dir) { # Search for dist.ini first
152             for my $file (map { $dir->catfile( $BUILDERS{ $_ } ) } $_builders->()) {
153             $file->exists and return $file
154             }
155              
156             $prev = $dir; $dir = $dir->parent;
157             }
158              
159             return;
160             };
161              
162             # Construction
163             sub BUILD {
164 1     1 1 1816 my $self = shift;
165              
166 1         3 for my $plugin (@{ $self->plugins }) {
  1         9  
167 0 0       0 if (first_char $plugin eq '+') { $plugin = substr $plugin, 1 }
  0         0  
168 0         0 else { $plugin = "Module::Provision::TraitFor::${plugin}" }
169              
170 0     0   0 try { Role::Tiny->apply_roles_to_object( $self, $plugin ) }
171             catch {
172 0 0   0   0 $_ =~ m{ \ACan\'t \s+ locate }mx
173             and throw 'Package [_1] not found in @INC', [ $plugin ];
174 0         0 throw $_;
175 0         0 };
176             }
177              
178 1         14 return;
179             }
180              
181             sub _build_appbase { # Base + distname
182 0     0   0 my $self = shift;
183 0         0 my $base = $self->base->absolute( $self->initial_wd );
184 0         0 my $appbase = $base->catdir( $self->distname );
185              
186 0 0       0 $appbase->exists and return $appbase;
187              
188             # This is so you can rename the dist directory
189 0         0 my $file = $_get_project_file->( $self->initial_wd );
190 0   0     0 my $grand_parent = $file && $file->parent && $file->parent->parent;
191              
192 0 0 0     0 $grand_parent and $grand_parent !~ m{ \.build \z }mx
      0        
193             and $grand_parent->exists and return $grand_parent;
194              
195 0         0 return $appbase;
196             }
197              
198             sub _build_appldir {
199 0     0   0 my $self = shift; my $appbase = $self->appbase; my $branch = $self->branch;
  0         0  
  0         0  
200              
201 0         0 my $home = $self->config->my_home; my $vcs = $self->vcs;
  0         0  
202              
203 0         0 (my $rel_appbase = $appbase) =~ s{ \Q$home\E [\\/] }{}mx;
204              
205 0 0       0 $self->debug and $self->info
206             ( "Appbase: ${rel_appbase}, Branch: ${branch}, VCS: ${vcs}" );
207              
208 0 0       0 return $vcs eq 'none' ? $appbase
    0          
    0          
    0          
209             : $appbase->catdir( '.git' )->exists ? $appbase
210             : $appbase->catdir( '.svn' )->exists ? $appbase
211             : $appbase->catdir( $branch )->exists ? $appbase->catdir( $branch )
212             : undef;
213             }
214              
215             sub _build_branch {
216 0 0   0   0 my $self = shift; my $branch = $ENV{BRANCH}; $branch and return $branch;
  0         0  
  0         0  
217              
218 0 0       0 $self->branch_file->exists and return $self->branch_file->chomp->getline;
219              
220 0         0 return $self->default_branch;
221             }
222              
223             sub _build_builder {
224 0     0   0 my $self = shift; my $appldir = $self->appldir;
  0         0  
225              
226 0         0 for (map { [ $appldir->catfile( $BUILDERS{ $_ } ), $_ ] } $_builders->()) {
  0         0  
227 0 0       0 $_->[ 0 ]->exists and return $_->[ 1 ];
228             }
229              
230 0         0 return;
231             }
232              
233             sub _build_default_branch {
234 0   0 0   0 return $_[ 0 ]->config->default_branches->{ $_[ 0 ]->vcs } // NUL;
235             }
236              
237             sub _build_dist_version {
238 0     0   0 my $self = shift; my $meta = $self->module_metadata;
  0         0  
239              
240 0 0       0 return Perl::Version->new( $meta ? $meta->version : '0.1.1' );
241             }
242              
243             sub _build_exec_perms {
244 1     1   59 return (($_[ 0 ]->perms & oct '0444') >> 2) | $_[ 0 ]->perms;
245             }
246              
247             sub _build_homedir {
248 0     0     return [ $_[ 0 ]->libdir, classdir $_[ 0 ]->project ];
249             }
250              
251             sub _build_license_keys {
252             return {
253             perl => 'Perl_5',
254             perl_5 => 'Perl_5',
255 0           apache => [ map { "Apache_$_" } qw( 1_1 2_0 ) ],
256             artistic => 'Artistic_1_0',
257             artistic_2 => 'Artistic_2_0',
258 0           lgpl => [ map { "LGPL_$_" } qw( 2_1 3_0 ) ],
259             bsd => 'BSD',
260 0           gpl => [ map { "GPL_$_" } qw( 1 2 3 ) ],
261             mit => 'MIT',
262 0     0     mozilla => [ map { "Mozilla_$_" } qw( 1_0 1_1 ) ], };
  0            
263             }
264              
265             sub _build_manifest_paths {
266 0     0     my $self = shift;
267              
268 0           return [ grep { $_->exists }
269 0           map { io( $_parse_manifest_line->( $_ )->[ 0 ] ) }
270 0           grep { not m{ \A \s* [\#] }mx }
  0            
271             $self->appldir->catfile( 'MANIFEST' )->chomp->getlines ];
272             }
273              
274             sub _build_module_abstract {
275 0     0     my $self = shift; my $meta = $self->module_metadata; my $abstract = NUL;
  0            
  0            
276              
277 0 0 0       $meta and ($abstract = $meta->pod( 'Name' ) // NUL)
278 0           =~ s{ \A [^\-]+ \s* [\-] \s* }{}mx; chomp $abstract;
279              
280 0   0       return $self->loc( $abstract || $self->config->module_abstract );
281             }
282              
283             sub _build_project {
284 0     0     my $self = shift;
285 0 0         my $file = $_get_project_file->( $self->initial_wd )
286             or throw 'Path [_1] contains no project file', [ $self->initial_wd ];
287 0 0         my $module = $_get_module_from->( $file->all )
288             or throw 'File [_1] contains no module name', [ $file ];
289              
290 0           return $module;
291             }
292              
293             sub _build_project_file {
294 0     0     return $BUILDERS{ $_[ 0 ]->builder };
295             }
296              
297             sub _build_stash {
298 0     0     my $self = shift; my $config = $self->config; my $author = $config->author;
  0            
  0            
299              
300 0           my $project = $self->project; my $perl_ver = $self->config->min_perl_ver;
  0            
301              
302 0 0         my $perl_code = $self->method eq 'dist' ? "use ${perl_ver};" : NUL;
303              
304             return { abstract => $self->module_abstract,
305             appdir => class2appdir $self->distname,
306             author => $author,
307             author_email => $config->author_email,
308             author_id => $config->author_id,
309             author_ID => uc $config->author_id,
310             copyright => $ENV{ORGANIZATION} || $author,
311             copyright_year => time2str( '%Y' ),
312             creation_date => time2str,
313             dist_module => $self->dist_module->abs2rel( $self->appldir ),
314             dist_version => NUL.$self->dist_version,
315             distname => $self->distname,
316             first_name => lc ((split SPC, $author)[ 0 ]),
317             home_page => $config->home_page,
318             initial_wd => NUL.$self->initial_wd,
319             last_name => lc ((split SPC, $author)[ -1 ]),
320             lc_distname => lc $self->distname,
321             license => $self->license,
322 0   0       license_class => $self->license_keys->{ $self->license },
323             module => $project,
324             perl => $perl_ver,
325             prefix => (split m{ :: }mx, lc $project)[ -1 ],
326             project => $project,
327             pub_repo_prefix => $config->pub_repo_prefix,
328             use_perl => $perl_code,
329             version => $self->VERSION, };
330             }
331              
332             sub _build_vcs {
333 0     0     my $self = shift; my $appbase = $self->appbase;
  0            
334              
335 0 0         return $appbase->catdir( '.git' )->exists ? 'git'
    0          
    0          
    0          
    0          
336             : $appbase->catdir( 'master', '.git' )->exists ? 'git'
337             : $appbase->catdir( '.svn' )->exists ? 'svn'
338             : $appbase->catdir( 'trunk', '.svn' )->exists ? 'svn'
339             : $appbase->catdir( $self->repository )->exists ? 'svn'
340             : 'none';
341             }
342              
343             # Public methods
344             sub chdir {
345 0     0 1   my ($self, $dir) = @_;
346              
347 0 0         $dir or throw Unspecified, [ 'directory' ];
348 0 0         chdir $dir or throw 'Directory [_1] cannot chdir: [_2]', [ $dir, $OS_ERROR ];
349 0           return $dir;
350             }
351              
352             sub load_meta {
353 0     0 1   my ($self, $dir) = @_;
354              
355 0 0 0       not $dir and $self->builder eq 'DZ'
356             and $dir = io $self->distname.'-'.$self->dist_version;
357              
358 0 0         my $path = $dir ? $dir->catfile( 'META.json' ) : 'META.json';
359              
360 0           return CPAN::Meta->load_file( "${path}" );
361             }
362              
363             1;
364              
365             __END__
366              
367             =pod
368              
369             =encoding utf-8
370              
371             =head1 Name
372              
373             Module::Provision::Base - Immutable data object
374              
375             =head1 Synopsis
376              
377             use Moose;
378              
379             extends 'Module::Provision::Base';
380              
381             =head1 Description
382              
383             Creates an immutable data object required by the methods in the applied roles
384              
385             =head1 Configuration and Environment
386              
387             Defines the following list of attributes which can be set from the
388             command line;
389              
390             =over 3
391              
392             =item C<base>
393              
394             The directory which will contain the new project. Defaults to the users
395             home directory
396              
397             =item C<branch>
398              
399             The name of the initial branch to create. Defaults to F<master> for
400             Git and F<trunk> for SVN
401              
402             =item C<builder>
403              
404             Which of the two build systems to use. Set to C<MB>
405             for L<Module::Build> or C<DZ> for L<Dist::Zilla>
406              
407             =item C<config_class>
408              
409             The name of the configuration class
410              
411             =item C<initial_wd>
412              
413             The working directory when the command was invoked
414              
415             =item C<license>
416              
417             The name of the license used on the project. Defaults to C<perl>
418              
419             =item C<perms>
420              
421             Permissions used to create files. Defaults to C<644>. Directories and
422             programs have the execute bit turned on if the corresponding read bit
423             is on
424              
425             =item C<plugins>
426              
427             Optional trait to load and apply
428              
429             =item C<project>
430              
431             The class name of the new project. Should be the first extra argument on the
432             command line
433              
434             =item C<repository>
435              
436             Name of the directory containing the SVN repository. Defaults to F<repository>
437              
438             =item C<vcs>
439              
440             The version control system to use. Defaults to C<none>, can be C<git>
441             or C<svn>
442              
443             =back
444              
445             =head1 Subroutines/Methods
446              
447             =head2 BUILD
448              
449             Load and apply optional traits
450              
451             =head2 chdir
452              
453             $directory = $self->chdir( $directory );
454              
455             Changes the current working directory to the one supplied and returns it.
456             Throws if the operation was not successful
457              
458             =head2 load_meta
459              
460             $cpan_meta_object = $self->load_meta( $optional_directory );
461              
462             Loads the F<META.json> file and returns and object
463              
464             =head1 Diagnostics
465              
466             None
467              
468             =head1 Dependencies
469              
470             =over 3
471              
472             =item L<Class::Usul>
473              
474             =item L<File::DataClass>
475              
476             =item L<Module::Metadata>
477              
478             =item L<Module::Provision::Config>
479              
480             =item L<Perl::Version>
481              
482             =back
483              
484             =head1 Incompatibilities
485              
486             There are no known incompatibilities in this module
487              
488             =head1 Bugs and Limitations
489              
490             There are no known bugs in this module.
491             Please report problems to the address below.
492             Patches are welcome
493              
494             =head1 Acknowledgements
495              
496             Larry Wall - For the Perl programming language
497              
498             =head1 Author
499              
500             Peter Flanigan, C<< <pjfl@cpan.org> >>
501              
502             =head1 License and Copyright
503              
504             Copyright (c) 2017 Peter Flanigan. All rights reserved
505              
506             This program is free software; you can redistribute it and/or modify it
507             under the same terms as Perl itself. See L<perlartistic>
508              
509             This program is distributed in the hope that it will be useful,
510             but WITHOUT WARRANTY; without even the implied warranty of
511             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
512              
513             =cut
514              
515             # Local Variables:
516             # mode: perl
517             # tab-width: 3
518             # End: