File Coverage

blib/lib/Module/Release/SVN.pm
Criterion Covered Total %
statement 14 74 18.9
branch 0 20 0.0
condition n/a
subroutine 5 12 41.6
pod 6 7 85.7
total 25 113 22.1


line stmt bran cond sub pod time code
1 1     1   1096 use v5.16;
  1         4  
2              
3             package Module::Release::SVN;
4              
5 1     1   6 use strict;
  1         2  
  1         20  
6 1     1   5 use warnings;
  1         2  
  1         25  
7 1     1   5 use Exporter qw(import);
  1         2  
  1         36  
8              
9 1     1   7 use Carp;
  1         2  
  1         1113  
10              
11             our @EXPORT = qw(check_vcs vcs_tag make_vcs_tag);
12              
13             our $VERSION = '2.128';
14              
15             =encoding utf8
16              
17             =head1 NAME
18              
19             Module::Release::SVN - Use Subversion with Module::Release
20              
21             =head1 SYNOPSIS
22              
23             The release script automatically loads this module if it sees a
24             F<.svn> directory. The module exports check_cvs, cvs_tag, and make_cvs_tag.
25              
26             =head1 DESCRIPTION
27              
28             C is a plugin for C, and provides
29             its own implementations of the C and C methods
30             that are suitable for use with a Subversion repository rather than a
31             CVS repository.
32              
33             These methods are B exported in to the callers namespace
34             using Exporter. You should only use it from C or its
35             subclasses.
36              
37             This module depends on the external svn binary (so far).
38              
39             =cut
40              
41             =over 4
42              
43             =item C
44              
45             DEPRECATED. Use C now.
46              
47             =item C
48              
49             Check the state of the SVN repository.
50              
51             =cut
52              
53             sub check_cvs {
54 0     0 1   carp "check_cvs is deprecated in favor of check_vcs. Update your programs!";
55 0           &check_vcs;
56             }
57              
58             sub check_vcs {
59 0     0 1   my $self = shift;
60              
61 0           $self->_print( "Checking state of Subversion..." );
62              
63 0           my $svn_update = $self->run('svn status --show-updates --verbose 2>&1');
64              
65 0 0         $self->_die(
66             sprintf("\nERROR: svn failed with non-zero exit status: %d\n\n"
67             . "Aborting release\n", $? >> 8)
68             ) if $?;
69              
70 0           $svn_update =~ s/^\?\s+/?/;
71 0           $svn_update =~ s/^(........)\s+\d+\s+\d+\s+\S+\s+(.*)$/$1 $2/mg;
72              
73 0           my %message = (
74             qr/^C......./m => 'These files have conflicts',
75             qr/^M......./m => 'These files have not been checked in',
76             qr/^........\*/m => 'These files need to be updated',
77             qr/^P......./m => 'These files need to be patched',
78             qr/^A......./m => 'These files were added but not checked in',
79             qr/^D......./m => 'These files are scheduled for deletion',
80             qr/^\?......./m => 'I don\'t know about these files',
81             );
82              
83 0           my @svn_states = keys %message;
84              
85 0           my %svn_state;
86 0           foreach my $state (@svn_states) {
87 0           $svn_state{$state} = [ $svn_update =~ /$state\s+(.*)/g ];
88             }
89              
90 0           my $count;
91             my $question_count;
92              
93 0           foreach my $key ( sort keys %svn_state ) {
94 0           my $list = $svn_state{$key};
95 0 0         next unless @$list;
96              
97 0 0         $count += @$list unless $key eq qr/^\?......./;
98 0 0         $question_count += @$list if $key eq qr/^\?......./;
99              
100 0           local $" = "\n\t";
101 0           $self->_print( "\n\t$message{$key}\n", "-" x 50, "\n\t@$list\n" );
102             }
103              
104 0 0         $self->_die( "\nERROR: Subversion is not up-to-date ($count files): Can't release!\n" )
105             if $count;
106              
107             =pod
108              
109             if($question_count)
110             {
111             $self->_print "\nWARNING: Subversion is not up-to-date ($question_count files unknown); ",
112             "continue anyway? [Ny] " ;
113             die "Exiting\n" unless <> =~ /^[yY]/;
114             }
115              
116             =cut
117              
118 0           $self->_print( "Subversion up-to-date\n" );
119             }
120              
121             =item C
122              
123             DEPRECATED. Use C now.
124              
125             =item C
126              
127             Tag the release in Subversion.
128              
129             =cut
130              
131              
132             sub cvs_tag {
133 0     0 1   carp "cvs_tag is deprecated in favor of vcs_tag. Update your programs!";
134 0           &check_vcs;
135             }
136              
137             sub vcs_tag {
138 0     0 1   require URI;
139              
140 0           my $self = shift;
141              
142 0           my $svn_info = $self->run('svn info .');
143              
144 0 0         if($?)
145             {
146 0           $self->_warn(
147             sprintf(
148             "\nWARNING: 'svn info .' failed with non-zero exit status: %d\n",
149             $? >> 8 )
150             );
151              
152 0           return;
153             }
154              
155 0           $svn_info =~ /^URL: (.*)$/m;
156 0           my $trunk_url = URI->new( $1 );
157              
158 0           my @tag_url = $trunk_url->path_segments;
159 0 0         if(! grep /^trunk$/, @tag_url ) {
160 0           $self->_warn(
161             "\nWARNING: Current SVN URL:\n $trunk_url\ndoes not contain a 'trunk' component\n",
162             "Aborting tagging.\n"
163             );
164              
165 0           return;
166             }
167              
168 0           foreach( @tag_url ) {
169 0 0         if($_ eq 'trunk') {
170 0           $_ = 'tags';
171 0           last;
172             }
173             }
174              
175 0           my $tag_url = $trunk_url->clone;
176              
177 0           $tag_url->path_segments( @tag_url );
178              
179             # Make sure the top-level path exists
180             #
181             # Can't use $self->run() because of a bug where $fh isn't closed, which
182             # stops $? from being properly propagated. Reported to brian d foy as
183             # part of RT#6489
184 0           $self->run( "svn list $tag_url 2>&1" );
185 0 0         if( $? ) {
186 0           $self->_warn(
187             sprintf("\nWARNING:\n svn list $tag_url\nfailed with non-zero exit status: %d\n", $? >> 8),
188             "Assuming tagging directory does not exist in repo. Please create it.\n",
189             "Aborting tagging.\n"
190             );
191              
192 0           return;
193             }
194              
195 0           my $tag = $self->make_vcs_tag;
196              
197 0           push @tag_url, $tag;
198 0           $tag_url->path_segments(@tag_url);
199 0           $self->_print( "Tagging release to $tag_url\n" );
200              
201 0           $self->run( "svn copy $trunk_url $tag_url" );
202              
203 0 0         if ( $? ) {
204             # already uploaded, and tagging is not (?) essential, so warn, don't die
205 0           $self->_warn(
206             sprintf(
207             "\nWARNING: svn failed with non-zero exit status: %d\n",
208             $? >> 8 )
209             );
210             }
211              
212             }
213              
214             =item C
215              
216             DEPRECATED. Use C now.
217              
218             =item make_vcs_tag
219              
220             By default, examines the name of the remote file
221             (i.e. F) and constructs a tag string like
222             C from it. Override this method if you want to use a
223             different tagging scheme, or don't even call it.
224              
225             =cut
226              
227              
228             sub make_cvs_tag {
229 0     0 1   carp "make_cvs_tag is deprecated in favor of make_vcs_tag. Update your programs!";
230 0           &make_vcs_tag;
231             }
232              
233             sub make_vcs_tag {
234 0     0 1   my $self = shift;
235 0           my( $major, $minor ) = $self->remote_file
236             =~ /(\d+) \. (\d+(?:_\d+)?) (?:\. tar \. gz)? $/xg;
237              
238 0           return "RELEASE_${major}_${minor}";
239             }
240              
241 0     0 0   sub vcs_exit { 1 }
242              
243             =back
244              
245             =head1 SEE ALSO
246              
247             L
248              
249             =head1 SOURCE AVAILABILITY
250              
251             This source is in GitHub
252              
253             https://github.com/briandfoy/module-release
254              
255             =head1 AUTHOR
256              
257             brian d foy, C<< >>
258              
259             =head1 COPYRIGHT AND LICENSE
260              
261             Copyright © 2007-2021, brian d foy C<< >>. All rights reserved.
262              
263             This program is free software; you can redistribute it and/or modify
264             it under the Artistic License 2.0.
265              
266             =cut
267              
268             1;