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		36229	use strict;
	1					1
	1					21
4	1			1		3	use warnings;
	1					1
	1					19
5	1			1		2	use Carp 'croak';
	1					1
	1					32
6	1			1		496	use Path::Iterator::Rule;
	1					8301
	1					22
7	1			1		5	use Path::Tiny;
	1					1
	1					34
8	1			1		366	use version ();
	1					1188
	1					22
9	1			1		349	use Version::Next 'next_version';
	1					7950
	1					5
10
11							use Class::Tiny::Chained {
12	1					10	allow_decimal_underscore => 0,
13							dry_run => 0,
14							follow_symlinks => 0,
15							global => 0,
16							verbose => 0,
17	1			1		530	};
	1					2620
18
19							our $VERSION = '0.005';
20
21							sub bump_version {
22	12			12	1	6225	my ($self, $version, $bump) = @_;
23	12	50				21	croak qq{Version is required for bump_version} unless defined $version;
24
25	12					20	$self->_check_version($version);
26
27	7	100				10	if (defined $bump) {
28	2	50				5	croak qq{Invalid bump coderef for bump_version} unless ref $bump eq 'CODE';
29	2					4	$version = $bump->($version);
30							} else {
31	5					12	$version = next_version($version);
32							}
33
34	7					281	return $version;
35							}
36
37							sub current_version {
38	10			10	1	3504	my ($self, %params) = @_;
39	10	100				33	my $dist_dir = path(defined $params{dist_dir} ? $params{dist_dir} : '.');
40	10					122	my $version_from = $params{file};
41
42	10	50				23	return $ENV{V} if defined $ENV{V};
43
44	10	100				21	$version_from = $self->_main_module($dist_dir) unless defined $version_from;
45	9					15	my $version = $self->version_from($version_from);
46	9	100				19	croak qq{No version found in file "$version_from"} unless defined $version;
47	8					31	return $version;
48							}
49
50							sub rewrite_version {
51	27			27	1	2037	my ($self, $file, $version, %params) = @_;
52	27	50				49	croak qq{File to rewrite must be specified for rewrite_version} unless defined $file;
53	27					65	$file = path($file);
54	27	100				550	croak qq{Version to rewrite must be specified for rewrite_version} unless defined $version;
55	26					26	my $is_trial = $params{is_trial};
56
57	26					43	$self->_check_version($version);
58
59	22	50				58	return 0 unless -T $file;
60	22					734	my $content = $file->slurp_utf8;
61
62	22					2016	my $code = qq{our \$VERSION = '$version';};
63	22	100				41	$code .= " # TRIAL" if $is_trial;
64
65	22	100	66			77	$code .= qq{\n\$VERSION = eval \$VERSION;}
66							if $version =~ m/_/ and scalar($version =~ m/\./g) <= 1;
67
68	22					30	my $assign_regex = _assign_re();
69	22					134	my $new_version_obj = version->parse($version);
70	22	50				395	if ($self->global ? ($content =~ s{^$assign_regex[^\n]*$}{$code}msg)
		100
71							: ($content =~ s{^$assign_regex[^\n]*$}{$code}ms)) {
72	17					396	my $old_version_obj = version->parse($2);
73	17	100				74	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				274	$file->append_utf8({truncate => 1}, $content) unless $self->dry_run;
77	17					2707	return 1;
78							}
79
80	5					48	return 0;
81							}
82
83							sub rewrite_versions {
84	10			10	1	1681	my ($self, $version, %params) = @_;
85	10	50				21	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					115	my $is_trial = $params{is_trial};
88	10	100				25	my $subdirs = defined $params{subdirs} ? $params{subdirs} : [qw(lib script bin)];
89	10					14	my @target_dirs = map { $dist_dir->child($_)->stringify } @$subdirs;
	28					374
90
91	10					168	$self->_check_version($version);
92
93	5					21	my @perl_file_rules = (
94							Path::Iterator::Rule->new->perl_module,
95							Path::Iterator::Rule->new->perl_script,
96							);
97	5					1278	my $rule = Path::Iterator::Rule->new->skip_vcs->file->ascii->or(@perl_file_rules);
98	5					2611	my %options = (follow_symlinks => $self->follow_symlinks);
99	5					33	my $iter = $rule->iter(@target_dirs, \%options);
100	5					450	while (defined(my $file = $iter->())) {
101	17					8129	my $rewritten = $self->rewrite_version($file, $version, is_trial => $is_trial);
102	17	50				400	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					248	return $self;
109							}
110
111							sub version_from {
112	28			28	1	475	my ($self, $file) = @_;
113	28	50				50	croak qq{File is required for version_from} unless defined $file;
114	28					58	$file = path($file);
115
116	28	50				318	return undef unless -T $file;
117	28					948	my $content = $file->slurp_utf8;
118
119	28					2489	my $assign_regex = _assign_re();
120	28					285	my ($quote, $version) = $content =~ m{^$assign_regex[^\n]*$}ms;
121
122	28	50	66			453	print qq{Extracted version from $file: $version\n} if $version and $self->verbose;
123	28					201	return $version;
124							}
125
126							sub _check_version {
127	48			48		41	my ($self, $version) = @_;
128	48	100				844	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					61	return $self;
131							}
132
133							sub _dist_name {
134	8			8		8	my ($self, $dist_dir) = @_;
135
136							# Adapted from Dist::Zilla::Plugin::NameFromDirectory
137	8					16	my $name = $dist_dir->absolute->basename;
138	8					147	$name =~ s/(?:^(?:perl\|p5)-\|[\-\.]pm$)//;
139	8	50				142	print qq{Guessing distribution name is $name\n} if $self->verbose;
140
141	8					55	return $name;
142							}
143
144							sub _main_module {
145	8			8		8	my ($self, $dist_dir) = @_;
146
147							# Adapted from Dist::Zilla
148	8					8	my $main;
149	8					11	(my $guess = $self->_dist_name($dist_dir)) =~ s{-}{/}g;
150	8					24	$main = $dist_dir->child("lib/$guess.pm");
151	8	100				190	unless ($main->exists) {
152	2					39	$main = path($self->_shortest_module($dist_dir));
153							}
154	7	50	33			157	croak qq{Could not find any modules to retrieve version from}
155							unless defined $main and $main->exists;
156
157	7	50				189	print qq{Using "$main" as dist's main module\n} if $self->verbose;
158	7					30	return $main;
159							}
160
161							sub _shortest_module {
162	2			2		2	my ($self, $dist_dir) = @_;
163	2					4	my $lib_dir = $dist_dir->child('lib')->stringify;
164	2					53	my $rule = Path::Iterator::Rule->new->skip_vcs->file->ascii->perl_module;
165	2					1197	my %options = (follow_symlinks => $self->follow_symlinks);
166	2					13	return (sort { length $a <=> length $b } $rule->all($lib_dir, \%options))[0];
	3					1297
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		1607	sub _is_strict_version { defined $_[0] && $_[0] =~ qr/\A $STRICT \z /x }
195
196							sub _is_loose_version {
197	9	50		9		356	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		356	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							}x;
211							}
212
213							}
214							# end of copied section
215
216							1;
217
218							=head1 NAME
219
220							App::RewriteVersion - A tool to rewrite and bump your Perl module versions
221
222							=head1 SYNOPSIS
223
224							use App::RewriteVersion;
225							my $app = App::RewriteVersion->new;
226
227							# Options
228							$app->verbose(1)->follow_symlinks(0);
229
230							# Bump versions for modules in current dist directory
231							$app->rewrite_versions($app->bump_version($app->current_version));
232
233							# Bump versions in specified dist directory
234							$app->rewrite_versions($app->bump_version($app->current_version(dist_dir => $dist_dir)), dist_dir => $dist_dir);
235
236							# Override module to read version from
237							$app->rewrite_versions($app->bump_version($app->current_version(file => $file)));
238
239							# Bump versions in specific subdirectories
240							$app->rewrite_versions($app->bump_version($app->current_version), subdirs => ['foo','bar']);
241
242							# Custom version bump algorithm
243							$app->rewrite_versions($app->bump_version($app->current_version, sub { shift + 0.05 }));
244
245							# Don't bump, just synchronize versions with main module
246							$app->rewrite_versions($app->current_version);
247
248							# Set versions to specified version
249							$app->rewrite_versions('0.065');
250
251							=head1 DESCRIPTION
252
253							L is a tool for managing Perl module versions in a
254							distribution. It is heavily based on the L plugin
255							L. Similarly to that plugin, the C
256							environment variable can be used to override the version detected from the main
257							module.
258
259							Existing version assignments and new versions must be parseable with the same
260							rules as in L, that is to
261							say, they should either be a decimal number with a single decimal point, or a
262							tuple version with a leading C and at least 3 segments separated by decimal
263							points. Version assignments should be in the form C.
264
265							See L and L for details on
266							command-line usage.
267
268							=head1 ATTRIBUTES
269
270							=head2 allow_decimal_underscore
271
272							my $bool = $app->allow_decimal_underscore;
273							$app = $app->allow_decimal_underscore(1);
274
275							If true, decimal versions with underscores will be allowed. Defaults to false.
276							See L
277							for more information.
278
279							=head2 dry_run
280
281							my $bool = $app->dry_run;
282							$app = $app->dry_run(1);
283
284							If true, the module will process files as normal but not actually modify them.
285							Useful with L to verify expected functionality.
286
287							=head2 follow_symlinks
288
289							my $bool = $app->follow_symlinks;
290							$app = $app->follow_symlinks(1);
291
292							If true, the application will follow symlinked directories when traversing the
293							distribution for modules. Defaults to false.
294
295							=head2 global
296
297							my $bool = $app->global;
298							$app = $app->global(1);
299
300							If true, the application will replace all version assignments found instead of
301							just the first instance in each file. Defaults to false.
302
303							=head2 verbose
304
305							my $bool = $app->verbose;
306							$app = $app->verbose(1);
307
308							Enable progress messages to be printed to STDOUT. Defaults to false.
309
310							=head1 METHODS
311
312							=head2 new
313
314							my $app = App::RewriteVersion->new;
315
316							Construct a new L object.
317
318							=head2 bump_version
319
320							my $new_version = $app->bump_version($version);
321							my $new_version = $app->bump_version($version, sub { $_[0] + 1 });
322
323							Increments a version string, returning the new version string. An optional
324							coderef can be passed for custom version bump logic. The coderef will receive
325							the current version string as the first argument and is expected to return a
326							new version string. By default, L is used. An exception will be
327							thrown if an invalid version is passed according to the current settings.
328
329							=head2 current_version
330
331							my $current_version = $app->current_version;
332							my $current_version = $app->current_version(dist_dir => $dist_dir);
333							my $current_version = $app->current_version(file => $file);
334
335							Returns the current version of the distribution using L. If no
336							C is passed, the main module filename will be guessed from C
337							(defaulting to current working directory), using heuristics similar to
338							L and L. For
339							example, if the directory is named C it will look for
340							C within the distribution, and if that doesn't exist, the
341							shortest module path found. If the C environment variable is set, it will be
342							returned regardless of other options. An exception will be thrown if no version
343							is found in the specified or guessed file, or if no perl modules could be
344							found.
345
346							=head2 rewrite_version
347
348							my $bool = $app->rewrite_version($file, $version);
349							my $bool = $app->rewrite_version($file, $version, is_trial => $is_trial);
350
351							Rewrites the version of the file at C<$file> to C<$version> if it has a version
352							assignment in the form C. Returns true if the version
353							was rewritten, or false if no version assignment was found. If C is
354							true, C<# TRIAL> will be appended to the version assignment line when
355							rewriting. An exception will be thrown if an invalid version is passed, or an
356							I/O error occurs. A warning will be printed if C<$version> is lower than the
357							version previously declared in the file.
358
359							=head2 rewrite_versions
360
361							$app = $app->rewrite_versions($version);
362							$app = $app->rewrite_versions($version, dist_dir => $dist_dir);
363							$app = $app->rewrite_versions($version, is_trial => 1);
364							$app = $app->rewrite_versions($version, subdirs => ['lib']);
365
366							Rewrites the versions of all perl files found in C (defaulting to
367							current working directory) to C<$version> using L. The
368							C option can be used to specify an arrayref of subdirectories relative
369							to C in which versions will be rewritten, otherwise defaulting to
370							C, C