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		79573	use strict;
	1					10
	1					24
4	1			1		4	use warnings;
	1					2
	1					21
5	1			1		4	use Carp 'croak';
	1					2
	1					35
6	1			1		467	use Path::Iterator::Rule;
	1					10799
	1					22
7	1			1		6	use Path::Tiny;
	1					2
	1					36
8	1			1		345	use version ();
	1					1442
	1					25
9	1			1		348	use Version::Next 'next_version';
	1					9156
	1					5
10
11							use Class::Tiny::Chained {
12	1					9	allow_decimal_underscore => 0,
13							dry_run => 0,
14							follow_symlinks => 0,
15							global => 0,
16							verbose => 0,
17	1			1		538	};
	1					1952
18
19							our $VERSION = '0.006';
20
21							sub bump_version {
22	12			12	1	6673	my ($self, $version, $bump) = @_;
23	12	50				31	croak qq{Version is required for bump_version} unless defined $version;
24
25	12					28	$self->_check_version($version);
26
27	7	100				15	if (defined $bump) {
28	2	50				6	croak qq{Invalid bump coderef for bump_version} unless ref $bump eq 'CODE';
29	2					5	$version = $bump->($version);
30							} else {
31	5					16	$version = next_version($version);
32							}
33
34	7					334	return $version;
35							}
36
37							sub current_version {
38	10			10	1	3942	my ($self, %params) = @_;
39	10	100				39	my $dist_dir = path(defined $params{dist_dir} ? $params{dist_dir} : '.');
40	10					162	my $version_from = $params{file};
41
42	10	50				27	return $ENV{V} if defined $ENV{V};
43
44	10	100				31	$version_from = $self->_main_module($dist_dir) unless defined $version_from;
45	9					17	my $version = $self->version_from($version_from);
46	9	100				21	croak qq{No version found in file "$version_from"} unless defined $version;
47	8					44	return $version;
48							}
49
50							sub rewrite_version {
51	27			27	1	2087	my ($self, $file, $version, %params) = @_;
52	27	50				58	croak qq{File to rewrite must be specified for rewrite_version} unless defined $file;
53	27					64	$file = path($file);
54	27	100				685	croak qq{Version to rewrite must be specified for rewrite_version} unless defined $version;
55	26					37	my $is_trial = $params{is_trial};
56
57	26					55	$self->_check_version($version);
58
59	22	50				71	return 0 unless -T $file;
60	22					932	my $content = $file->slurp_utf8;
61
62	22					2821	my $code = qq{our \$VERSION = '$version';};
63	22	100				50	$code .= " # TRIAL" if $is_trial;
64
65	22	100	66			78	$code .= qq{\n\$VERSION =~ tr/_//d;}
66							if $version =~ m/_/ and scalar($version =~ m/\./g) <= 1;
67
68	22					41	my $assign_regex = _assign_re();
69	22					167	my $new_version_obj = version->parse($version);
70	22	50				408	if ($self->global ? ($content =~ s{^$assign_regex[^\n]*$}{$code}msg)
		100
71							: ($content =~ s{^$assign_regex[^\n]*$}{$code}ms)) {
72	17					392	my $old_version_obj = version->parse($2);
73	17	100				112	if ($new_version_obj < $old_version_obj) {
74	1					3	warn qq{Updating \$VERSION assignment in "$file" to lower version ($old_version_obj -> $new_version_obj)\n};
75							}
76	17	50				273	$file->append_utf8({truncate => 1}, $content) unless $self->dry_run;
77	17					4051	return 1;
78							}
79
80	5					55	return 0;
81							}
82
83							sub rewrite_versions {
84	10			10	1	2035	my ($self, $version, %params) = @_;
85	10	50				26	croak qq{Version to rewrite must be specified for rewrite_versions} unless defined $version;
86	10	100				34	my $dist_dir = path(defined $params{dist_dir} ? $params{dist_dir} : '.');
87	10					149	my $is_trial = $params{is_trial};
88	10	100				25	my $subdirs = defined $params{subdirs} ? $params{subdirs} : [qw(lib script bin)];
89	10					12	my @target_dirs = map { $dist_dir->child($_)->stringify } @$subdirs;
	28					564
90
91	10					275	$self->_check_version($version);
92
93	5					22	my @perl_file_rules = (
94							Path::Iterator::Rule->new->perl_module,
95							Path::Iterator::Rule->new->perl_script,
96							);
97	5					1897	my $rule = Path::Iterator::Rule->new->skip_vcs->file->ascii->or(@perl_file_rules);
98	5					3500	my %options = (follow_symlinks => $self->follow_symlinks);
99	5					39	my $iter = $rule->iter(@target_dirs, \%options);
100	5					517	while (defined(my $file = $iter->())) {
101	17					11115	my $rewritten = $self->rewrite_version($file, $version, is_trial => $is_trial);
102	17	50				334	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					285	return $self;
109							}
110
111							sub version_from {
112	28			28	1	649	my ($self, $file) = @_;
113	28	50				54	croak qq{File is required for version_from} unless defined $file;
114	28					58	$file = path($file);
115
116	28	50				382	return undef unless -T $file;
117	28					1265	my $content = $file->slurp_utf8;
118
119	28					3662	my $assign_regex = _assign_re();
120	28					329	my ($quote, $version) = $content =~ m{^$assign_regex[^\n]*$}ms;
121
122	28	50	66			498	print qq{Extracted version from $file: $version\n} if $version and $self->verbose;
123	28					219	return $version;
124							}
125
126							sub _check_version {
127	48			48		74	my ($self, $version) = @_;
128	48	100				896	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					65	return $self;
131							}
132
133							sub _dist_name {
134	8			8		13	my ($self, $dist_dir) = @_;
135
136							# Adapted from Dist::Zilla::Plugin::NameFromDirectory
137	8					18	my $name = $dist_dir->absolute->basename;
138	8					192	$name =~ s/(?:^(?:perl\|p5)-\|[\-\.]pm$)//;
139	8	50				143	print qq{Guessing distribution name is $name\n} if $self->verbose;
140
141	8					57	return $name;
142							}
143
144							sub _main_module {
145	8			8		13	my ($self, $dist_dir) = @_;
146
147							# Adapted from Dist::Zilla
148	8					12	my $main;
149	8					14	(my $guess = $self->_dist_name($dist_dir)) =~ s{-}{/}g;
150	8					26	$main = $dist_dir->child("lib/$guess.pm");
151	8	100				255	unless ($main->exists) {
152	2					40	$main = path($self->_shortest_module($dist_dir));
153							}
154	7	50	33			151	croak qq{Could not find any modules to retrieve version from}
155							unless defined $main and $main->exists;
156
157	7	50				211	print qq{Using "$main" as dist's main module\n} if $self->verbose;
158	7					37	return $main;
159							}
160
161							sub _shortest_module {
162	2			2		6	my ($self, $dist_dir) = @_;
163	2					6	my $lib_dir = $dist_dir->child('lib')->stringify;
164	2					75	my $rule = Path::Iterator::Rule->new->skip_vcs->file->ascii->perl_module;
165	2					2136	my %options = (follow_symlinks => $self->follow_symlinks);
166	2					17	return (sort { length $a <=> length $b } $rule->all($lib_dir, \%options))[0];
	3					1882
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	39	50		39		1572	sub _is_strict_version { defined $_[0] && $_[0] =~ qr/\A $STRICT \z /x }
195
196							sub _is_loose_version {
197	9	50		9		372	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		392	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(1);
276
277							If true, decimal versions with underscores will be allowed. Defaults to false.
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. An exception will be thrown if an invalid version is passed, or an
358							I/O error occurs. A warning will be printed if C<$version> is lower than the
359							version previously declared in the file.
360
361							=head2 rewrite_versions
362
363							$app = $app->rewrite_versions($version);
364							$app = $app->rewrite_versions($version, dist_dir => $dist_dir);
365							$app = $app->rewrite_versions($version, is_trial => 1);
366							$app = $app->rewrite_versions($version, subdirs => ['lib']);
367
368							Rewrites the versions of all perl files found in C (defaulting to
369							current working directory) to C<$version> using L. The
370							C option can be used to specify an arrayref of subdirectories relative
371							to C in which versions will be rewritten, otherwise defaulting to
372							C, C