Update podlators to version 4.03
[perl.git] / cpan / podlators / t / style / module-version.t
1 #!/usr/bin/perl
2 #
3 # Check or update the version of Perl modules.
4 #
5 # Examines all module files (*.pm) under the lib directory and verifies that
6 # the package is set to the same value as the current version number as
7 # determined by the MYMETA.json file at the top of the source distribution.
8 #
9 # When given the --update option, instead fixes all of the Perl modules found
10 # to have the correct version.
11
12 use 5.006;
13 use strict;
14 use warnings;
15
16 use lib 't/lib';
17
18 use Carp qw(croak);
19 use File::Find qw(find);
20 use Getopt::Long qw(GetOptions);
21 use Test::More;
22 use Test::RRA qw(skip_unless_automated use_prereq);
23
24 # If we have options, we're being run from the command line and always load
25 # our prerequisite modules.  Otherwise, check if we have necessary
26 # prerequisites and should run as a test suite.
27 if (@ARGV) {
28     require JSON::PP;
29     require Perl6::Slurp;
30     Perl6::Slurp->import;
31 } else {
32     skip_unless_automated('Module version tests');
33     use_prereq('JSON::PP');
34     use_prereq('Perl6::Slurp');
35 }
36
37 # A regular expression matching the version string for a module using the
38 # package syntax from Perl 5.12 and later.  $1 will contain all of the line
39 # contents prior to the actual version string, $2 will contain the version
40 # itself, and $3 will contain the rest of the line.
41 our $REGEX_VERSION_PACKAGE = qr{
42     (                           # prefix ($1)
43         \A \s*                  # whitespace
44         package \s+             # package keyword
45         [\w\:\']+ \s+           # package name
46     )
47     ( v? [\d._]+ )              # the version number itself ($2)
48     (                           # suffix ($3)
49         \s* ;
50     )
51 }xms;
52
53 # A regular expression matching a $VERSION string in a module.  $1 will
54 # contain all of the line contents prior to the actual version string, $2 will
55 # contain the version itself, and $3 will contain the rest of the line.
56 our $REGEX_VERSION_OLD = qr{
57     (                           # prefix ($1)
58         \A .*                   # any prefix, such as "our"
59         [\$*]                   # scalar or typeglob
60         [\w\:\']*\b             # optional package name
61         VERSION\b               # version variable
62         \s* = \s*               # assignment
63     )
64     [\"\']?                     # optional leading quote
65     ( v? [\d._]+ )              # the version number itself ($2)
66     [\"\']?                     # optional trailing quote
67     (                           # suffix ($3)
68         \s*
69         ;
70     )
71 }xms;
72
73 # Find all the Perl modules shipped in this package, if any, and returns the
74 # list of file names.
75 #
76 # $dir - The root directory to search, lib by default
77 #
78 # Returns: List of file names
79 sub module_files {
80     my ($dir) = @_;
81     $dir ||= 'lib';
82     return if !-d $dir;
83     my @files;
84     my $wanted = sub {
85         if ($_ eq 'blib') {
86             $File::Find::prune = 1;
87             return;
88         }
89         if (m{ [.] pm \z }xms) {
90             push(@files, $File::Find::name);
91         }
92         return;
93     };
94     find($wanted, $dir);
95     return @files;
96 }
97
98 # Given a module file, read it for the version value and return the value.
99 #
100 # $file - File to check, which should be a Perl module
101 #
102 # Returns: The version of the module
103 #  Throws: Text exception on I/O failure or inability to find version
104 sub module_version {
105     my ($file) = @_;
106     open(my $data, q{<}, $file) or die "$0: cannot open $file: $!\n";
107     while (defined(my $line = <$data>)) {
108         if (   $line =~ $REGEX_VERSION_PACKAGE
109             || $line =~ $REGEX_VERSION_OLD)
110         {
111             my ($prefix, $version, $suffix) = ($1, $2, $3);
112             close($data) or die "$0: error reading from $file: $!\n";
113             return $version;
114         }
115     }
116     close($data) or die "$0: error reading from $file: $!\n";
117     die "$0: cannot find version number in $file\n";
118 }
119
120 # Return the current version of the distribution from MYMETA.json in the
121 # current directory.
122 #
123 # Returns: The version number of the distribution
124 # Throws: Text exception if MYMETA.json is not found or doesn't contain a
125 #         version
126 sub dist_version {
127     my $json     = JSON::PP->new->utf8(1);
128     my $metadata = $json->decode(scalar(slurp('MYMETA.json')));
129     my $version  = $metadata->{version};
130     if (!defined($version)) {
131         die "$0: cannot find version number in MYMETA.json\n";
132     }
133     return $version;
134 }
135
136 # Given a module file and the new version for that module, update the version
137 # in that module to the new one.
138 #
139 # $file    - Perl module file whose version should be updated
140 # $version - The new version number
141 #
142 # Returns: undef
143 #  Throws: Text exception on I/O failure or inability to find version
144 sub update_module_version {
145     my ($file, $version) = @_;
146     open(my $in, q{<}, $file) or die "$0: cannot open $file: $!\n";
147     open(my $out, q{>}, "$file.new")
148       or die "$0: cannot create $file.new: $!\n";
149
150     # If the version starts with v, use it without quotes.  Otherwise, quote
151     # it to prevent removal of trailing zeroes.
152     if ($version !~ m{ \A v }xms) {
153         $version = "'$version'";
154     }
155
156     # Scan for the version and replace it.
157   SCAN:
158     while (defined(my $line = <$in>)) {
159         if (   $line =~ s{ $REGEX_VERSION_PACKAGE }{$1$version$3}xms
160             || $line =~ s{ $REGEX_VERSION_OLD     }{$1$version$3}xms)
161         {
162             print {$out} $line or die "$0: cannot write to $file.new: $!\n";
163             last SCAN;
164         }
165         print {$out} $line or die "$0: cannot write to $file.new: $!\n";
166     }
167
168     # Copy the rest of the input file to the output file.
169     print {$out} <$in> or die "$0: cannot write to $file.new: $!\n";
170     close($out) or die "$0: cannot flush $file.new: $!\n";
171     close($in)  or die "$0: error reading from $file: $!\n";
172
173     # All done.  Rename the new file over top of the old file.
174     rename("$file.new", $file)
175       or die "$0: cannot rename $file.new to $file: $!\n";
176     return;
177 }
178
179 # Act as a test suite.  Find all of the Perl modules in the package, if any,
180 # and check that the version for each module matches the version of the
181 # distribution.  Reports results with Test::More and sets up a plan based on
182 # the number of modules found.
183 #
184 # Returns: undef
185 #  Throws: Text exception on fatal errors
186 sub test_versions {
187     my $dist_version = dist_version();
188     my @modules      = module_files();
189
190     # Output the plan.  Skip the test if there were no modules found.
191     if (@modules) {
192         plan tests => scalar(@modules);
193     } else {
194         plan skip_all => 'No Perl modules found';
195         return;
196     }
197
198     # For each module, get the module version and compare.
199     for my $module (@modules) {
200         my $module_version = module_version($module);
201         is($module_version, $dist_version, "Version for $module");
202     }
203     return;
204 }
205
206 # Update the versions of all modules to the current distribution version.
207 #
208 # Returns: undef
209 #  Throws: Text exception on fatal errors
210 sub update_versions {
211     my $version = dist_version();
212     my @modules = module_files();
213     for my $module (@modules) {
214         update_module_version($module, $version);
215     }
216     return;
217 }
218
219 # Main routine.  We run as either a test suite or as a script to update all of
220 # the module versions, selecting based on whether we got the -u / --update
221 # command-line option.
222 my $update;
223 Getopt::Long::config('bundling', 'no_ignore_case');
224 GetOptions('update|u' => \$update) or exit 1;
225 if ($update) {
226     update_versions();
227 } else {
228     test_versions();
229 }
230 exit 0;
231 __END__
232
233 =for stopwords
234 Allbery sublicense MERCHANTABILITY NONINFRINGEMENT CPAN
235
236 =head1 NAME
237
238 module-version.t - Check or update versions of Perl modules
239
240 =head1 SYNOPSIS
241
242 B<module-version.t> [B<--update>]
243
244 =head1 REQUIREMENTS
245
246 Perl 5.6.0 or later, the Perl6::Slurp module, and the JSON::PP Perl
247 module, both of which are available from CPAN.  JSON::PP is also included
248 in Perl core in Perl 5.14 and later.
249
250 =head1 DESCRIPTION
251
252 This script has a dual purpose as either a test script or a utility
253 script.  The intent is to assist with maintaining consistent versions in a
254 Perl distribution, supporting both the package keyword syntax introduced
255 in Perl 5.12 or the older explicit setting of a $VERSION variable.
256
257 As a test, it reads the current version of a package from the
258 F<MYMETA.json> file in the current directory (which should be the root of
259 the distribution) and then looks for any Perl modules in F<lib>.  If it
260 finds any, it checks that the version number of the Perl module matches
261 the version number of the package from the F<MYMETA.json> file.  These
262 test results are reported with Test::More, suitable for any TAP harness.
263
264 As a utility script, when run with the B<--update> option, it similarly
265 finds all Perl modules in F<lib> and then rewrites their version setting
266 to match the version of the package as determined from the F<MYMETA.json>
267 file.
268
269 =head1 OPTIONS
270
271 =over 4
272
273 =item B<-u>, B<--update>
274
275 Rather than test the Perl modules for the correct version, update all
276 Perl modules found in the tree under F<lib> to the current version
277 from the C<MYMETA.json> file.
278
279 =back
280
281 =head1 AUTHOR
282
283 Russ Allbery <eagle@eyrie.org>
284
285 =head1 COPYRIGHT AND LICENSE
286
287 Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior
288 University
289
290 Copyright 2014, 2015 Russ Allbery <eagle@eyrie.org>
291
292 Permission is hereby granted, free of charge, to any person obtaining a
293 copy of this software and associated documentation files (the "Software"),
294 to deal in the Software without restriction, including without limitation
295 the rights to use, copy, modify, merge, publish, distribute, sublicense,
296 and/or sell copies of the Software, and to permit persons to whom the
297 Software is furnished to do so, subject to the following conditions:
298
299 The above copyright notice and this permission notice shall be included in
300 all copies or substantial portions of the Software.
301
302 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
303 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
304 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
305 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
306 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
307 FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
308 DEALINGS IN THE SOFTWARE.
309
310 =head1 SEE ALSO
311
312 This module is maintained in the rra-c-util package.  The current version
313 is available from L<http://www.eyrie.org/~eagle/software/rra-c-util/>.
314
315 =cut