Omnibus strict and lax version parsing

Authors: John Peacock, David Golden and Zefram

The goal of this mega-patch is to enforce strict rules for version
numbers provided to 'package NAME VERSION' while formalizing the prior,
lax rules used for version object creation.  Parsing for use() is
unchanged.

version.pm adds two globals, $STRICT and $LAX, containing regular
expressions that define the rules.  There are two additional functions
-- version::is_strict and version::is_lax -- that test an argument
against these rules.

However, parsing of strings that might contain version numbers is done
in core via the Perl_scan_version function, which may be called during
compilation or may be called later when version objects are created by
Perl_new_version or Perl_upg_version.

A new helper function, Perl_prescan_version, has been added to validate
a string under either strict or lax rules.  This is used in toke.c for
'package NAME VERSION' in strict mode and by Perl_scan_version in lax
mode.  It matches the behavior of the verison.pm regular expressions,
but does not use them directly.

A new test file, comp/packagev.t, validates strict and lax behaviors of
'package NAME VERSION' and 'version->new(VERSION)' respectively and
verifies their behavior against the $STRICT and $LAX regular
expressions, as well.  Validating these two implementation should help
ensure they each work as intended.

Other files and tests have been modified as necessary to support these
changes.

There is remaining work to be done in a few areas:

* documenting all changes in behavior and new functions

* determining proper treatment of "," as decimal separators in
  various locales

* updating diagnostics for new error messages

* porting changes back to the version.pm distribution on CPAN,
  including pure-Perl versions

2 files changed, 124 insertions, 29 deletions

diff --git a/lib/version.pm b/lib/version.pm
index 9201a02157..424463d035 100644
--- a/lib/version.pm
+++ b/lib/version.pm
@@ -4,12 +4,116 @@ package version;
 use 5.005_04;
 use strict;
 
-use vars qw(@ISA $VERSION $CLASS *declare *qv);
+use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
 
-$VERSION = 0.77;
+$VERSION = 0.81;
 
 $CLASS = 'version';
 
+#--------------------------------------------------------------------------#
+# Version regexp components
+#--------------------------------------------------------------------------#
+
+# Fraction part of a decimal version number.  This is a common part of
+# both strict and lax decimal versions
+
+my $FRACTION_PART = qr/\.[0-9]+/;
+
+# First part of either decimal or dotted-decimal strict version number.
+# Unsigned integer with no leading zeroes (except for zero itself) to
+# avoid confusion with octal.
+
+my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
+
+# First part of either decimal or dotted-decimal lax version number.
+# Unsigned integer, but allowing leading zeros.  Always interpreted
+# as decimal.  However, some forms of the resulting syntax give odd
+# results if used as ordinary Perl expressions, due to how perl treats
+# octals.  E.g.
+#   version->new("010" ) == 10
+#   version->new( 010  ) == 8
+#   version->new( 010.2) == 82  # "8" . "2"
+
+my $LAX_INTEGER_PART = qr/[0-9]+/;
+
+# Second and subsequent part of a strict dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal.
+# Limited to three digits to avoid overflow when converting to decimal
+# form and also avoid problematic style with excessive leading zeroes.
+
+my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
+
+# Second and subsequent part of a lax dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal.  No
+# limit on the numerical value or number of digits, so there is the
+# possibility of overflow when converting to decimal form.
+
+my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
+
+# Alpha suffix part of lax version number syntax.  Acts like a
+# dotted-decimal part.
+
+my $LAX_ALPHA_PART = qr/_[0-9]+/;
+
+#--------------------------------------------------------------------------#
+# Strict version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Strict decimal version number.
+
+my $STRICT_DECIMAL_VERSION =
+    qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
+
+# Strict dotted-decimal version number.  Must have both leading "v" and
+# at least three parts, to avoid confusion with decimal syntax.
+
+my $STRICT_DOTTED_DECIMAL_VERSION =
+    qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
+
+# Complete strict version number syntax -- should generally be used
+# anchored: qr/ \A $STRICT \z /x
+
+$STRICT =
+    qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+# Lax version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Lax decimal version number.  Just like the strict one except for
+# allowing an alpha suffix or allowing a leading or trailing
+# decimal-point
+
+my $LAX_DECIMAL_VERSION =
+    qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
+	|
+	$FRACTION_PART $LAX_ALPHA_PART?
+    /x;
+
+# Lax dotted-decimal version number.  Distinguished by having either
+# leading "v" or at least three non-alpha parts.  Alpha part is only
+# permitted if there are at least two non-alpha parts. Strangely
+# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
+# so when there is no "v", the leading part is optional
+
+my $LAX_DOTTED_DECIMAL_VERSION =
+    qr/
+	v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
+	|
+	$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
+    /x;
+
+# Complete lax version number syntax -- should generally be used
+# anchored: qr/ \A $LAX \z /x
+#
+# The string 'undef' is a special case to make for easier handling
+# of return values from ExtUtils::MM->parse_version
+
+$LAX =
+    qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+
 # Preloaded methods go here.
 sub import {
     no strict 'refs';
@@ -33,7 +137,7 @@ sub import {
 	    'UNIVERSAL::VERSION' => 1,
 	);
     }
-    
+
     my $callpkg = caller();
     
     if (exists($args{declare})) {
@@ -53,4 +157,7 @@ sub import {
     }
 }
 
+sub is_strict	{ defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
+sub is_lax	{ defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
+
 1;
diff --git a/lib/version.t b/lib/version.t
index 8067f1aced..f44cfea93f 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -132,43 +132,32 @@ sub BaseTests {
     
     # test illegal formats
     diag "test illegal formats" unless $ENV{PERL_CORE};
-    eval {my $version = $CLASS->$method("1.2_3_4")};
+    eval {$version = $CLASS->$method("1.2_3_4")};
     like($@, qr/multiple underscores/,
 	"Invalid version format (multiple underscores)");
     
-    eval {my $version = $CLASS->$method("1.2_3.4")};
+    eval {$version = $CLASS->$method("1.2_3.4")};
     like($@, qr/underscores before decimal/,
 	"Invalid version format (underscores before decimal)");
     
-    eval {my $version = $CLASS->$method("1_2")};
+    eval {$version = $CLASS->$method("1_2")};
     like($@, qr/alpha without decimal/,
 	"Invalid version format (alpha without decimal)");
     
-    # for this test, upgrade the warn() to die()
-    eval {
-	local $SIG{__WARN__} = sub { die $_[0] };
-	$version = $CLASS->$method("1.2b3");
-    };
-    my $warnregex = "Version string '.+' contains invalid data; ".
-	    "ignoring: '.+'";
-
-    like($@, qr/$warnregex/,
-	"Version string contains invalid data; ignoring");
+    eval { $version = $CLASS->$method("1.2b3")};
+    like($@, qr/non-numeric data/,
+	"Invalid version format (non-numeric data)");
 
     # from here on out capture the warning and test independently
     {
-    $version = $CLASS->$method("99 and 44/100 pure");
+    eval{$version = $CLASS->$method("99 and 44/100 pure")};
 
-    like($warning, qr/$warnregex/,
-	"Version string contains invalid data; ignoring");
-    is ("$version", "99", '$version eq "99"');
-    ok ($version->numify == 99.0, '$version->numify == 99.0');
-    ok ($version->normal eq "v99.0.0", '$version->normal eq v99.0.0');
+    like($@, qr/non-numeric data/,
+	"Invalid version format (non-numeric data)");
     
-    $version = $CLASS->$method("something");
-    like($warning, qr/$warnregex/,
-	"Version string contains invalid data; ignoring");
-    ok (defined $version, 'defined $version');
+    eval{$version = $CLASS->$method("something")};
+    like($@, qr/non-numeric data/,
+	"Invalid version format (non-numeric data)");
     
     # reset the test object to something reasonable
     $version = $CLASS->$method("1.2.3");
@@ -557,9 +546,8 @@ SKIP: {
 	local $SIG{__WARN__} = sub { $warning = $_[0] };
 
 $DB::single = 1;
-	my $v = $CLASS->$method('1,7');
-	unlike($warning, qr"Version string '1,7' contains invalid data",
-	    'Directly test comma as decimal compliance');
+	my $v = eval { $CLASS->$method('1,7') };
+#	is( $@, "", 'Directly test comma as decimal compliance');
 
 	my $ver = 1.23;  # has to be floating point number
 	my $orig_loc = setlocale( LC_ALL );