File Coverage

blib/lib/App/RewriteVersion.pm

Criterion	Covered	Total	%
statement	111	112	99.1
branch	45	64	70.3
condition	5	9	55.5
subroutine	20	20	100.0
pod	5	5	100.0
total	186	210	88.5

line	stmt	bran	cond	sub	pod	time	code
1							package App::RewriteVersion;
2
3	1			1		98290	use strict;
	1					14
	1					29
4	1			1		5	use warnings;
	1					1
	1					27
5	1			1		5	use Carp 'croak';
	1					2
	1					54
6	1			1		603	use Path::Iterator::Rule;
	1					14088
	1					31
7	1			1		7	use Path::Tiny;
	1					2
	1					47
8	1			1		414	use version ();
	1					1778
	1					30
9	1			1		419	use Version::Next 'next_version';
	1					11566
	1					6
10
11							use Class::Tiny::Chained {
12	1					12	allow_decimal_underscore => 1,
13							dry_run => 0,
14							follow_symlinks => 0,
15							global => 0,
16							verbose => 0,
17	1			1		679	};
	1					2806
18
19							our $VERSION = '1.000';
20
21							sub bump_version {
22	12			12	1	6665	my ($self, $version, $bump) = @_;
23	12	50				34	croak qq{Version is required for bump_version} unless defined $version;
24
25	12					34	$self->_check_version($version);
26
27	7	100				17	if (defined $bump) {
28	2	50				7	croak qq{Invalid bump coderef for bump_version} unless ref $bump eq 'CODE';
29	2					6	$version = $bump->($version);
30							} else {
31	5					17	$version = next_version($version);
32							}
33
34	7					443	return $version;
35							}
36
37							sub current_version {
38	10			10	1	5338	my ($self, %params) = @_;
39	10	100				46	my $dist_dir = path(defined $params{dist_dir} ? $params{dist_dir} : '.');
40	10					211	my $version_from = $params{file};
41
42	10	50				31	return $ENV{V} if defined $ENV{V};
43
44	10	100				36	$version_from = $self->_main_module($dist_dir) unless defined $version_from;
45	9					23	my $version = $self->version_from($version_from);
46	9	100				29	croak qq{No version found in file "$version_from"} unless defined $version;
47	8					85	return $version;
48							}
49
50							sub rewrite_version {
51	27			27	1	2747	my ($self, $file, $version, %params) = @_;
52	27	50				69	croak qq{File to rewrite must be specified for rewrite_version} unless defined $file;
53	27					73	$file = path($file);
54	27	100				804	croak qq{Version to rewrite must be specified for rewrite_version} unless defined $version;
55	26					48	my $is_trial = $params{is_trial};
56
57	26					68	$self->_check_version($version);
58
59	22	50				81	return 0 unless -T $file;
60	22					1105	my $content = $file->slurp_utf8;
61
62	22					3445	my $code = qq{our \$VERSION = '$version';};
63	22	100				65	$code .= " # TRIAL" if $is_trial;
64
65	22	100	66			97	$code .= qq{\n\$VERSION =~ tr/_//d;}
66							if $version =~ m/_/ and scalar($version =~ m/\./g) <= 1;
67
68	22					49	my $assign_regex = _assign_re();
69	22					191	my $new_version_obj = version->parse($version);
70	22	50				509	if ($self->global ? ($content =~ s{^$assign_regex[^\n]*$}{$code}msg)
		100
71							: ($content =~ s{^$assign_regex[^\n]*$}{$code}ms)) {
72	17					480	my $old_version_obj = version->parse($2);
73	17	100				97	if ($new_version_obj < $old_version_obj) {
74	1					4	warn qq{Updating \$VERSION assignment in "$file" to lower version ($old_version_obj -> $new_version_obj)\n};
75							}
76	17	50				342	$file->append_utf8({truncate => 1}, $content) unless $self->dry_run;
77	17					5089	return 1;
78							}
79
80	5					104	return 0;
81							}
82
83							sub rewrite_versions {
84	10			10	1	2550	my ($self, $version, %params) = @_;
85	10	50				30	croak qq{Version to rewrite must be specified for rewrite_versions} unless defined $version;
86	10	100				39	my $dist_dir = path(defined $params{dist_dir} ? $params{dist_dir} : '.');
87	10					169	my $is_trial = $params{is_trial};
88	10	100				33	my $subdirs = defined $params{subdirs} ? $params{subdirs} : [qw(lib script bin)];
89	10					19	my @target_dirs = map { $dist_dir->child($_)->stringify } @$subdirs;
	28					653
90
91	10					334	$self->_check_version($version);
92
93	5					29	my @perl_file_rules = (
94							Path::Iterator::Rule->new->perl_module,
95							Path::Iterator::Rule->new->perl_script,
96							);
97	5					2391	my $rule = Path::Iterator::Rule->new->skip_vcs->file->ascii->or(@perl_file_rules);
98	5					4483	my %options = (follow_symlinks => $self->follow_symlinks);
99	5					43	my $iter = $rule->iter(@target_dirs, \%options);
100	5					658	while (defined(my $file = $iter->())) {
101	17					14029	my $rewritten = $self->rewrite_version($file, $version, is_trial => $is_trial);
102	17	50				411	if ($self->verbose) {
103	0	0				0	print $rewritten ? qq{Updated \$VERSION assignment in "$file" to $version\n}
104							: qq{Skipping: no "our \$VERSION = '...'" found in "$file"\n};
105							}
106							}
107
108	5					305	return $self;
109							}
110
111							sub version_from {
112	28			28	1	847	my ($self, $file) = @_;
113	28	50				66	croak qq{File is required for version_from} unless defined $file;
114	28					77	$file = path($file);
115
116	28	50				452	return undef unless -T $file;
117	28					1477	my $content = $file->slurp_utf8;
118
119	28					4538	my $assign_regex = _assign_re();
120	28					399	my ($quote, $version) = $content =~ m{^$assign_regex[^\n]*$}ms;
121
122	28	50	66			578	print qq{Extracted version from $file: $version\n} if $version and $self->verbose;
123	28					278	return $version;
124							}
125
126							sub _check_version {
127	48			48		93	my ($self, $version) = @_;
128	48	100				1057	croak qq{$version is not an allowed version string} unless
		100
129							$self->allow_decimal_underscore ? _is_loose_version($version) : _is_strict_version($version);
130	34					82	return $self;
131							}
132
133							sub _dist_name {
134	8			8		14	my ($self, $dist_dir) = @_;
135
136							# Adapted from Dist::Zilla::Plugin::NameFromDirectory
137	8					24	my $name = $dist_dir->absolute->basename;
138	8					247	$name =~ s/(?:^(?:perl\|p5)-\|[\-\.]pm$)//;
139	8	50				179	print qq{Guessing distribution name is $name\n} if $self->verbose;
140
141	8					74	return $name;
142							}
143
144							sub _main_module {
145	8			8		20	my ($self, $dist_dir) = @_;
146
147							# Adapted from Dist::Zilla
148	8					10	my $main;
149	8					20	(my $guess = $self->_dist_name($dist_dir)) =~ s{-}{/}g;
150	8					34	$main = $dist_dir->child("lib/$guess.pm");
151	8	100				310	unless ($main->exists) {
152	2					65	$main = path($self->_shortest_module($dist_dir));
153							}
154	7	50	33			184	croak qq{Could not find any modules to retrieve version from}
155							unless defined $main and $main->exists;
156
157	7	50				265	print qq{Using "$main" as dist's main module\n} if $self->verbose;
158	7					51	return $main;
159							}
160
161							sub _shortest_module {
162	2			2		5	my ($self, $dist_dir) = @_;
163	2					7	my $lib_dir = $dist_dir->child('lib')->stringify;
164	2					93	my $rule = Path::Iterator::Rule->new->skip_vcs->file->ascii->perl_module;
165	2					2234	my %options = (follow_symlinks => $self->follow_symlinks);
166	2					20	return (sort { length $a <=> length $b } $rule->all($lib_dir, \%options))[0];
	3					2327
167							}
168
169							# this section copied from Dist::Zilla::Plugin::BumpVersionAfterRelease::_Util
170							{
171
172							# version regexes from version.pm
173							my $FRACTION_PART = qr/\.[0-9]+/;
174							my $STRICT_INTEGER_PART = qr/0\|[1-9][0-9]*/;
175							my $LAX_INTEGER_PART = qr/[0-9]+/;
176							my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
177							my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
178							my $LAX_ALPHA_PART = qr/_[0-9]+/;
179							my $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
180							my $STRICT_DOTTED_DECIMAL_VERSION =
181							qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
182							my $STRICT = qr/ $STRICT_DECIMAL_VERSION \| $STRICT_DOTTED_DECIMAL_VERSION /x;
183							my $LAX_DECIMAL_VERSION =
184							qr/ $LAX_INTEGER_PART (?: \. \| $FRACTION_PART $LAX_ALPHA_PART? )?
185							\|
186							$FRACTION_PART $LAX_ALPHA_PART?
187							/x;
188							my $LAX_DOTTED_DECIMAL_VERSION = qr/
189							v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
190							\|
191							$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
192							/x;
193
194	3	50		3		348	sub _is_strict_version { defined $_[0] && $_[0] =~ qr/\A $STRICT \z /x }
195
196							sub _is_loose_version {
197	45	50		45		2106	defined $_[0] && $_[0] =~ qr/\A (?: $STRICT \| $LAX_DECIMAL_VERSION ) \z /x;
198							}
199
200							# Because this is used for capturing or replacing, we take anything
201							# that is a lax version (but not literal string 'undef', so we don't want
202							# version::LAX). Later anything captured needs to be checked with the
203							# strict or loose version check functions.
204							sub _assign_re {
205	50			50		477	return qr{
206							our \s+ \$VERSION \s* = \s*
207							(['"])($LAX_DECIMAL_VERSION \| $LAX_DOTTED_DECIMAL_VERSION)\1 \s* ;
208							(?:\s* \# \s TRIAL)? [^\n]*
209							(?:\n \$VERSION \s = \s eval \s \$VERSION;)?
210							(?:\n \$VERSION \s =~ \s tr/_//d;)?
211							(?:\n \$VERSION \s =~ \s s/_//g?;)?
212							}x;
213							}
214
215							}
216							# end of copied section
217
218							1;
219
220							=head1 NAME
221
222							App::RewriteVersion - A tool to rewrite and bump your Perl module versions
223
224							=head1 SYNOPSIS
225
226							use App::RewriteVersion;
227							my $app = App::RewriteVersion->new;
228
229							# Options
230							$app->verbose(1)->follow_symlinks(0);
231
232							# Bump versions for modules in current dist directory
233							$app->rewrite_versions($app->bump_version($app->current_version));
234
235							# Bump versions in specified dist directory
236							$app->rewrite_versions($app->bump_version($app->current_version(dist_dir => $dist_dir)), dist_dir => $dist_dir);
237
238							# Override module to read version from
239							$app->rewrite_versions($app->bump_version($app->current_version(file => $file)));
240
241							# Bump versions in specific subdirectories
242							$app->rewrite_versions($app->bump_version($app->current_version), subdirs => ['foo','bar']);
243
244							# Custom version bump algorithm
245							$app->rewrite_versions($app->bump_version($app->current_version, sub { shift + 0.05 }));
246
247							# Don't bump, just synchronize versions with main module
248							$app->rewrite_versions($app->current_version);
249
250							# Set versions to specified version
251							$app->rewrite_versions('0.065');
252
253							=head1 DESCRIPTION
254
255							L is a tool for managing Perl module versions in a
256							distribution. It is heavily based on the L plugin
257							L. Similarly to that plugin, the C
258							environment variable can be used to override the version detected from the main
259							module.
260
261							Existing version assignments and new versions must be parseable with the same
262							rules as in L, that is to
263							say, they should either be a decimal number with a single decimal point, or a
264							tuple version with a leading C and at least 3 segments separated by decimal
265							points. Version assignments should be in the form C.
266
267							See L and L for details on
268							command-line usage.
269
270							=head1 ATTRIBUTES
271
272							=head2 allow_decimal_underscore
273
274							my $bool = $app->allow_decimal_underscore;
275							$app = $app->allow_decimal_underscore(0);
276
277							If true, decimal versions with underscores will be allowed. Defaults to true.
278							See L
279							for more information.
280
281							=head2 dry_run
282
283							my $bool = $app->dry_run;
284							$app = $app->dry_run(1);
285
286							If true, the module will process files as normal but not actually modify them.
287							Useful with L to verify expected functionality.
288
289							=head2 follow_symlinks
290
291							my $bool = $app->follow_symlinks;
292							$app = $app->follow_symlinks(1);
293
294							If true, the application will follow symlinked directories when traversing the
295							distribution for modules. Defaults to false.
296
297							=head2 global
298
299							my $bool = $app->global;
300							$app = $app->global(1);
301
302							If true, the application will replace all version assignments found instead of
303							just the first instance in each file. Defaults to false.
304
305							=head2 verbose
306
307							my $bool = $app->verbose;
308							$app = $app->verbose(1);
309
310							Enable progress messages to be printed to STDOUT. Defaults to false.
311
312							=head1 METHODS
313
314							=head2 new
315
316							my $app = App::RewriteVersion->new;
317
318							Construct a new L object.
319
320							=head2 bump_version
321
322							my $new_version = $app->bump_version($version);
323							my $new_version = $app->bump_version($version, sub { $_[0] + 1 });
324
325							Increments a version string, returning the new version string. An optional
326							coderef can be passed for custom version bump logic. The coderef will receive
327							the current version string as the first argument and is expected to return a
328							new version string. By default, L is used. An exception will be
329							thrown if an invalid version is passed according to the current settings.
330
331							=head2 current_version
332
333							my $current_version = $app->current_version;
334							my $current_version = $app->current_version(dist_dir => $dist_dir);
335							my $current_version = $app->current_version(file => $file);
336
337							Returns the current version of the distribution using L. If no
338							C is passed, the main module filename will be guessed from C
339							(defaulting to current working directory), using heuristics similar to
340							L and L. For
341							example, if the directory is named C it will look for
342							C within the distribution, and if that doesn't exist, the
343							shortest module path found. If the C environment variable is set, it will be
344							returned regardless of other options. An exception will be thrown if no version
345							is found in the specified or guessed file, or if no perl modules could be
346							found.
347
348							=head2 rewrite_version
349
350							my $bool = $app->rewrite_version($file, $version);
351							my $bool = $app->rewrite_version($file, $version, is_trial => $is_trial);
352
353							Rewrites the version of the file at C<$file> to C<$version> if it has a version
354							assignment in the form C. Returns true if the version
355							was rewritten, or false if no version assignment was found. If C is
356							true, C<# TRIAL> will be appended to the version assignment line when
357							rewriting. The C<-TRIAL> indication is not part of the version and should be
358							added to the name of the archive you upload to PAUSE, which is outside of the
359							scope of this tool. An exception will be thrown if an invalid version is
360							passed, or an I/O error occurs. A warning will be printed if C<$version> is
361							lower than the version previously declared in the file.
362
363							=head2 rewrite_versions
364
365							$app = $app->rewrite_versions($version);
366							$app = $app->rewrite_versions($version, dist_dir => $dist_dir);
367							$app = $app->rewrite_versions($version, is_trial => 1);
368							$app = $app->rewrite_versions($version, subdirs => ['lib']);
369
370							Rewrites the versions of all perl files found in C (defaulting to
371							current working directory) to C<$version> using L. The
372							C option can be used to specify an arrayref of subdirectories relative
373							to C in which versions will be rewritten, otherwise defaulting to
374							C, C