File Coverage

lib/Module/Provision/TraitFor/VCS.pm
Criterion Covered Total %
statement 27 66 40.9
branch 0 18 0.0
condition 0 15 0.0
subroutine 9 16 56.2
pod 6 6 100.0
total 42 121 34.7


line stmt bran cond sub pod time code
1             package Module::Provision::TraitFor::VCS;
2              
3 1     1   677 use namespace::autoclean;
  1         3  
  1         8  
4              
5 1     1   87 use Class::Usul::Constants qw( EXCEPTION_CLASS FALSE OK TRUE );
  1         3  
  1         8  
6 1     1   826 use Class::Usul::Functions qw( io is_win32 throw );
  1         3  
  1         8  
7 1     1   1231 use Class::Usul::Types qw( Bool HashRef Str );
  1         2  
  1         10  
8 1     1   888 use Perl::Version;
  1         3  
  1         23  
9 1     1   4 use Scalar::Util qw( blessed );
  1         2  
  1         61  
10 1     1   5 use Unexpected::Functions qw( Unspecified );
  1         3  
  1         9  
11 1     1   298 use Moo::Role;
  1         2  
  1         9  
12 1     1   366 use Class::Usul::Options;
  1         2  
  1         9  
13              
14             requires qw( add_leader appbase appldir branch build_distribution chdir config
15             cpan_upload default_branch dist_version distname editor exec_perms
16             extra_argv generate_metadata get_line loc next_argv output quiet
17             run_cmd test_upload update_version vcs );
18              
19             # Attribute constructors
20             my $_build_cmd_line_flags = sub {
21 0     0     my $self = shift; my $opts = {};
  0            
22              
23 0           for my $k (qw( release test upload nopush )) {
24             $self->extra_argv->[ 0 ] and $self->extra_argv->[ 0 ] eq $k
25 0 0 0       and $self->next_argv and $opts->{ $k } = TRUE;
      0        
26             }
27              
28 0           return $opts;
29             };
30              
31             # Public attributes
32             option 'no_auto_rev' => is => 'ro', isa => Bool, default => FALSE,
33             documentation => 'Do not turn on Revision keyword expansion';
34              
35             has 'cmd_line_flags' => is => 'lazy', isa => HashRef[Bool],
36             builder => $_build_cmd_line_flags;
37              
38             # Private attributes
39             has '_new_version' => is => 'rwp', isa => Str;
40              
41             # Private functions
42             my $_get_state_file_name = sub {
43             return (map { m{ load-project-state \s+ [\'\"](.+)[\'\"] }mx; }
44             grep { m{ eval: \s+ \( \s* load-project-state }mx }
45             io( $_[ 0 ] )->getlines)[ -1 ];
46             };
47              
48             my $_tag_from_version = sub {
49             my $ver = shift; return $ver->component( 0 ).'.'.$ver->component( 1 );
50             };
51              
52             # Private methods
53             my $_add_git_hooks = sub {
54             my ($self, @hooks) = @_;
55              
56             for my $hook (grep { -e ".git${_}" } @hooks) {
57             my $dest = $self->appldir->catfile( '.git', 'hooks', $hook );
58              
59             $dest->exists and $dest->unlink; link ".git${hook}", $dest;
60             chmod $self->exec_perms, ".git${hook}";
61             }
62              
63             return;
64             };
65              
66             my $_add_tag_to_git = sub {
67             my ($self, $tag) = @_;
68              
69             my $message = $self->loc( $self->config->tag_message );
70             my $sign = $self->config->signing_key; $sign and $sign = "-u ${sign}";
71              
72             $self->run_cmd( "git tag -d v${tag}", { err => 'null', expected_rv => 1 } );
73             $self->run_cmd( "git tag ${sign} -m '${message}' v${tag}" );
74             return;
75             };
76              
77             my $_add_to_git = sub {
78             my ($self, $target, $type) = @_;
79              
80             my $params = $self->quiet ? {} : { out => 'stdout' };
81              
82             $self->run_cmd( "git add ${target}", $params );
83             return;
84             };
85              
86             my $_add_to_svn = sub {
87             my ($self, $target, $type) = @_;
88              
89             my $params = $self->quiet ? {} : { out => 'stdout' };
90              
91             $self->run_cmd( "svn add ${target} --parents", $params );
92             $self->run_cmd( "svn propset svn:keywords 'Id Revision Auth' ${target}",
93             $params );
94             $type and $type eq 'program'
95             and $self->run_cmd( "svn propset svn:executable '*' ${target}", $params );
96             return;
97             };
98              
99             my $_commit_release_to_git = sub {
100             my ($self, $msg) = @_;
101              
102             $self->run_cmd( 'git add .' ); $self->run_cmd( "git commit -m '${msg}'" );
103              
104             return;
105             };
106              
107             my $_commit_release_to_svn = sub {
108             # TODO: Fill this in
109             };
110              
111             my $_get_rev_file = sub {
112             my $self = shift; ($self->no_auto_rev or $self->vcs ne 'git') and return;
113              
114             return $self->appldir->parent->catfile( lc '.'.$self->distname.'.rev' );
115             };
116              
117             my $_get_svn_repository = sub {
118             my $self = shift; my $info = $self->run_cmd( 'svn info' )->stdout;
119              
120             return (split m{ : \s }mx, (grep { m{ \A Repository \s Root: }mx }
121             split m{ \n }mx, $info)[ 0 ])[ 1 ];
122             };
123              
124             my $_get_version_numbers = sub {
125             my ($self, @args) = @_; $args[ 0 ] and $args[ 1 ] and return @args;
126              
127             my $prompt = '+Enter major/minor 0 or 1';
128             my $comp = $self->get_line( $prompt, 1, TRUE, 0 );
129             $prompt = '+Enter increment/decrement';
130             my $bump = $self->get_line( $prompt, 1, TRUE, 0 ) or return @args;
131             my ($from, $ver);
132              
133             if ($from = $args[ 0 ]) { $ver = Perl::Version->new( $from ) }
134             else {
135             $ver = $self->dist_version or return @args;
136             $from = $_tag_from_version->( $ver );
137             }
138              
139             $ver->component( $comp, $ver->component( $comp ) + $bump );
140             $comp == 0 and $ver->component( 1, 0 );
141              
142             return ($from, $_tag_from_version->( $ver ));
143             };
144              
145             my $_initialize_svn = sub {
146             my $self = shift; my $class = blessed $self; $self->chdir( $self->appbase );
147              
148             my $repository = $self->appbase->catdir( $self->repository );
149              
150             $self->run_cmd( "svnadmin create ${repository}" );
151              
152             my $branch = $self->branch;
153             my $url = 'file://'.$repository->catdir( $branch );
154             my $msg = $self->loc( 'Initialised by [_1]', $class );
155              
156             $self->run_cmd( "svn import ${branch} ${url} -m '${msg}'" );
157              
158             my $appldir = $self->appldir; $appldir->rmtree;
159              
160             $self->run_cmd( "svn co ${url}" );
161             $appldir->filter( sub { $_ !~ m{ \.git }msx and $_ !~ m{ \.svn }msx } );
162              
163             for my $target ($appldir->deep->all_files) {
164             $self->run_cmd( "svn propset svn:keywords 'Id Revision Auth' ${target}" );
165             }
166              
167             $msg = $self->loc( 'Add RCS keywords to project files' );
168             $self->run_cmd( "svn commit ${branch} -m '${msg}'" );
169             $self->chdir( $self->appldir );
170             $self->run_cmd( 'svn update' );
171             return;
172             };
173              
174             my $_push_to_git_remote = sub {
175             my $self = shift; my $info = $self->run_cmd( 'git remote -v' )->stdout;
176              
177             (grep { m{ \(push\) \z }mx } split m{ \n }mx, $info)[ 0 ] or return;
178              
179             my $params = $self->quiet ? {} : { out => 'stdout' };
180              
181             $self->run_cmd( 'git push --all', $params );
182             $self->run_cmd( 'git push --tags', $params );
183             return;
184             };
185              
186             my $_push_to_remote = sub {
187             my $self = shift;
188              
189             $self->vcs eq 'git' and $self->$_push_to_git_remote;
190             return;
191             };
192              
193             my $_svn_ignore_meta_files = sub {
194             my $self = shift; $self->chdir( $self->appldir );
195              
196             my $ignores = "LICENSE\nMANIFEST\nMETA.json\nMETA.yml\nREADME\nREADME.md";
197              
198             $self->run_cmd( "svn propset svn:ignore '${ignores}' ." );
199             $self->run_cmd( 'svn commit -m "Ignoring meta files" .' );
200             $self->run_cmd( 'svn update' );
201             return;
202             };
203              
204             my $_wrap = sub {
205             my $self = shift; my $method = shift; return not $self->$method( @_ );
206             };
207              
208             my $_add_tag_to_svn = sub {
209             my ($self, $tag) = @_; my $params = $self->quiet ? {} : { out => 'stdout' };
210              
211             my $repo = $self->$_get_svn_repository;
212             my $from = "${repo}/trunk";
213             my $to = "${repo}/tags/v${tag}";
214             my $message = $self->loc( $self->config->tag_message )." v${tag}";
215             my $cmd = "svn copy --parents -m '${message}' ${from} ${to}";
216              
217             $self->run_cmd( $cmd, $params );
218             return;
219             };
220              
221             my $_commit_release = sub {
222             my ($self, $tag) = @_; my $msg = $self->config->tag_message." v${tag}";
223              
224             $self->vcs eq 'git' and $self->$_commit_release_to_git( $msg );
225             $self->vcs eq 'svn' and $self->$_commit_release_to_svn( $msg );
226             return;
227             };
228              
229             my $_initialize_git = sub {
230             my $self = shift;
231             my $msg = $self->loc( 'Initialised by [_1]', blessed $self );
232              
233             $self->chdir( $self->appldir ); $self->run_cmd( 'git init' );
234              
235             $self->add_hooks; $self->$_commit_release_to_git( $msg );
236              
237             return;
238             };
239              
240             my $_reset_rev_file = sub {
241             my ($self, $create) = @_; my $file = $self->$_get_rev_file;
242              
243             $file and ($create or $file->exists)
244             and $file->println( $create ? '1' : '0' );
245             return;
246             };
247              
248             my $_reset_rev_keyword = sub {
249             my ($self, $path) = @_;
250              
251             my $zero = 0; # Zero variable prevents unwanted Rev keyword expansion
252              
253             $self->$_get_rev_file and $path->substitute
254             ( '\$ (Rev (?:ision)?) (?:[:] \s+ (\d+) \s+)? \$', '$Rev: '.$zero.' $' );
255             return;
256             };
257              
258             my $_add_tag = sub {
259             my ($self, $tag) = @_;
260              
261             $tag or throw Unspecified, [ 'VCS tag version' ];
262             $self->output( 'Creating tagged release v[_1]', { args => [ $tag ] } );
263             $self->vcs eq 'git' and $self->$_add_tag_to_git( $tag );
264             $self->vcs eq 'svn' and $self->$_add_tag_to_svn( $tag );
265             return;
266             };
267              
268             my $_initialize_vcs = sub {
269             my $self = shift;
270              
271             $self->vcs ne 'none' and $self->output( 'Initialising VCS' );
272             $self->vcs eq 'git' and $self->$_initialize_git;
273             $self->vcs eq 'svn' and $self->$_initialize_svn;
274             return;
275             };
276              
277             # Construction
278             around 'dist_post_hook' => sub {
279             my ($next, $self, @args) = @_; $self->$_initialize_vcs;
280              
281             my $r = $self->$next( @args );
282              
283             $self->vcs eq 'git' and $self->$_reset_rev_file( TRUE );
284             $self->vcs eq 'svn' and $self->$_svn_ignore_meta_files;
285             return $r;
286             };
287              
288             around 'release_distribution' => sub {
289             my ($orig, $self) = @_;
290              
291             $self->cmd_line_flags->{test}
292             and $self->$_wrap( 'build_distribution' )
293             and $self->$_wrap( 'test_upload', $self->dist_version );
294              
295             return $orig->( $self );
296             };
297              
298             around 'release_distribution' => sub {
299             my ($orig, $self) = @_; my $res = $orig->( $self );
300              
301             $self->cmd_line_flags->{upload}
302             and $self->$_wrap( 'build_distribution' )
303             and $self->$_wrap( 'cpan_upload' )
304             and $self->$_wrap( 'clean_distribution' );
305              
306             return $res;
307             };
308              
309             around 'release_distribution' => sub {
310             my ($orig, $self) = @_; my $res = $orig->( $self );
311              
312             $self->cmd_line_flags->{nopush} or $self->$_push_to_remote;
313              
314             return $res;
315             };
316              
317             around 'substitute_version' => sub {
318             my ($next, $self, $path, @args) = @_; my $r = $self->$next( $path, @args );
319              
320             $self->vcs eq 'git' and $self->$_reset_rev_keyword( $path );
321             return $r;
322             };
323              
324             around 'update_version_pre_hook' => sub {
325             my ($next, $self, @args) = @_;
326              
327             return $self->$next( $self->$_get_version_numbers( @args ) );
328             };
329              
330             around 'update_version_post_hook' => sub {
331             my ($next, $self, @args) = @_;
332              
333             $self->_set__new_version( $args[ 1 ] );
334             $self->clear_dist_version; $self->clear_module_metadata;
335              
336             my $result = $self->$next( @args );
337              
338             $self->vcs eq 'git' and $self->$_reset_rev_file( FALSE );
339              
340             return $result;
341             };
342              
343             # Public methods
344             sub add_hooks : method {
345 0     0 1   my $self = shift;
346              
347 0 0         $self->vcs eq 'git' and $self->$_add_git_hooks( @{ $self->config->hooks } );
  0            
348              
349 0           return OK;
350             }
351              
352             sub add_to_vcs {
353 0     0 1   my ($self, $target, $type) = @_;
354              
355 0 0         $target or throw Unspecified, [ 'VCS target' ];
356 0 0         $self->vcs eq 'git' and $self->$_add_to_git( $target, $type );
357 0 0         $self->vcs eq 'svn' and $self->$_add_to_svn( $target, $type );
358 0           return;
359             }
360              
361             sub get_emacs_state_file_path {
362 0     0 1   my ($self, $file) = @_; my $home = $self->config->my_home;
  0            
363              
364 0           return $home->catfile( '.emacs.d', 'config', "state.${file}" );
365             }
366              
367             sub release : method {
368 0     0 1   my $self = shift; $self->release_distribution; return OK;
  0            
  0            
369             }
370              
371             sub release_distribution {
372 0     0 1   my $self = shift;
373              
374 0           $self->update_version;
375 0           $self->generate_metadata;
376 0           $self->$_commit_release( $self->_new_version );
377 0           $self->$_add_tag( $self->_new_version );
378 0           return TRUE;
379             }
380              
381             sub set_branch : method {
382 0     0 1   my $self = shift; my $bfile = $self->branch_file;
  0            
383              
384 0           my $old_branch = $self->branch;
385 0   0       my $new_branch = $self->next_argv // $self->default_branch;
386              
387 0 0 0       not $new_branch and $bfile->exists and $bfile->unlink and return OK;
      0        
388 0 0         $new_branch and $bfile->println( $new_branch );
389              
390 0           my $method = 'get_'.$self->editor.'_state_file_path';
391              
392 0 0         $self->can( $method ) or return OK;
393              
394 0           my $sfname = $_get_state_file_name->( $self->project_file );
395 0           my $sfpath = $self->$method( $sfname );
396 0 0         my $sep = is_win32 ? "\\" : '/';
397              
398 0           $sfpath->substitute( "${sep}\Q${old_branch}\E${sep}",
399             "${sep}${new_branch}${sep}" );
400 0           return OK;
401             }
402              
403             1;
404              
405             __END__
406              
407             =pod
408              
409             =encoding utf-8
410              
411             =head1 Name
412              
413             Module::Provision::TraitFor::VCS - Version Control
414              
415             =head1 Synopsis
416              
417             use Module::Provision::TraitFor::VCS;
418             # Brief but working code examples
419              
420             =head1 Description
421              
422             Interface to Version Control Systems
423              
424             =head1 Configuration and Environment
425              
426             Modifies
427             L<Module::Provision::TraitFor::CreatingDistributions/dist_post_hook>
428             where it initialises the VCS, ignore meta files and resets the
429             revision number file
430              
431             Modifies
432             L<Module::Provision::TraitFor::UpdatingContent/substitute_version>
433             where it resets the Revision keyword values
434              
435             Modifies
436             L<Module::Provision::TraitFor::UpdatingContent/update_version_pre_hook>
437             where it prompts for version numbers and creates tagged releases
438              
439             Modifies
440             L<Module::Provision::TraitFor::UpdatingContent/update_version_post_hook>
441             where it resets the revision number file
442              
443             Requires these attributes to be defined in the consuming class;
444             C<appldir>, C<distname>, C<vcs>
445              
446             Defines the following command line options;
447              
448             =over 3
449              
450             =item C<no_auto_rev>
451              
452             Do not turn on automatic Revision keyword expansion. Defaults to C<FALSE>
453              
454             =back
455              
456             =head1 Subroutines/Methods
457              
458             =head2 add_hooks - Adds and re-adds any hooks used in the VCS
459              
460             $exit_code = $self->add_hooks;
461              
462             Returns the exit code
463              
464             =head2 add_to_vcs
465              
466             $self->add_to_vcs( $target, $type );
467              
468             Add the target file to the VCS
469              
470             =head2 get_emacs_state_file_path
471              
472             $io_object = $self->get_emacs_state_file_path( $file_name );
473              
474             Returns the L<File::DataClass::IO> object for the path to the Emacs editor's
475             state file
476              
477             =head2 release - Update version, commit and tag
478              
479             $exit_code = $self->release;
480              
481             Calls L</release_distribution>. Will optionally install the distribution
482             on a test server, upload the distribution to CPAN and push the repository
483             to the origin
484              
485             =head2 release_distribution
486              
487             Updates the distribution version, regenerates the metadata, commits the change
488             and tags the new release
489              
490             =head2 set_branch - Set the VCS branch name
491              
492             $exit_code = $self->set_branch;
493              
494             Sets the current branch to the value supplied on the command line
495              
496             =head1 Diagnostics
497              
498             None
499              
500             =head1 Dependencies
501              
502             =over 3
503              
504             =item L<Class::Usul>
505              
506             =item L<Moose::Role>
507              
508             =item L<Perl::Version>
509              
510             =back
511              
512             =head1 Incompatibilities
513              
514             There are no known incompatibilities in this module
515              
516             =head1 Bugs and Limitations
517              
518             There are no known bugs in this module.
519             Please report problems to the address below.
520             Patches are welcome
521              
522             =head1 Acknowledgements
523              
524             Larry Wall - For the Perl programming language
525              
526             =head1 Author
527              
528             Peter Flanigan, C<< <pjfl@cpan.org> >>
529              
530             =head1 License and Copyright
531              
532             Copyright (c) 2017 Peter Flanigan. All rights reserved
533              
534             This program is free software; you can redistribute it and/or modify it
535             under the same terms as Perl itself. See L<perlartistic>
536              
537             This program is distributed in the hope that it will be useful,
538             but WITHOUT WARRANTY; without even the implied warranty of
539             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
540              
541             =cut
542              
543             # Local Variables:
544             # mode: perl
545             # tab-width: 3
546             # End: