&utf8::unicode_to_native
$version::VERSION
$version::CLASS
+ $version::STRICT
+ $version::LAX
@version::ISA
], ($] >= 5.008001 && qw[
&Regexp::DESTROY
'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep' ) |, # 5.7.3
);
-plan tests => keys(%modules) * 4 + 5;
+plan tests => keys(%modules) * 3 + 5;
# Try to load the module
use_ok( 'XSLoader' );
SKIP: {
skip "$module not available", 4 if $extensions !~ /\b$module\b/;
- eval qq{ package $module; XSLoader::load('$module', "qunckkk"); };
- like( $@, "/^$module object version \\S+ does not match bootstrap parameter (?:qunckkk|0)/",
+ eval qq{ package $module; XSLoader::load('$module', "12345678"); };
+ like( $@, "/^$module object version \\S+ does not match bootstrap parameter (?:12345678|0)/",
"calling XSLoader::load() with a XS module and an incorrect version" );
- like( $warnings, "/^\$|^Version string 'qunckkk' contains invalid data; ignoring: 'qunckkk'/",
- "in Perl 5.10, DynaLoader warns about the incorrect version string" );
eval qq{ package $module; XSLoader::load('$module'); };
is( $@, '', "XSLoader::load($module)");
Ap |char* |scan_vstring |NN const char *s|NN const char *const e \
|NN SV *sv
Apd |const char* |scan_version |NN const char *s|NN SV *rv|bool qv
+Apd |const char* |prescan_version |NN const char *s\
+ |bool strict|NULLOK const char** errstr|bool *sqv|int *ssaw_period|int *swidth|bool *salpha
Apd |SV* |new_version |NN SV *ver
Apd |SV* |upg_version |NN SV *ver|bool qv
Apd |bool |vverify |NN SV *vs
s |void |check_uni
s |void |force_next |I32 type
s |char* |force_version |NN char *s|int guessing
+s |char* |force_strict_version |NN char *s
s |char* |force_word |NN char *start|int token|int check_keyword \
|int allow_pack|int allow_tick
s |SV* |tokeq |NN SV *sv
#define new_stackinfo Perl_new_stackinfo
#define scan_vstring Perl_scan_vstring
#define scan_version Perl_scan_version
+#define prescan_version Perl_prescan_version
#define new_version Perl_new_version
#define upg_version Perl_upg_version
#define vverify Perl_vverify
#define check_uni S_check_uni
#define force_next S_force_next
#define force_version S_force_version
+#define force_strict_version S_force_strict_version
#define force_word S_force_word
#define tokeq S_tokeq
#define readpipe_override S_readpipe_override
#define new_stackinfo(a,b) Perl_new_stackinfo(aTHX_ a,b)
#define scan_vstring(a,b,c) Perl_scan_vstring(aTHX_ a,b,c)
#define scan_version(a,b,c) Perl_scan_version(aTHX_ a,b,c)
+#define prescan_version(a,b,c,d,e,f,g) Perl_prescan_version(aTHX_ a,b,c,d,e,f,g)
#define new_version(a) Perl_new_version(aTHX_ a)
#define upg_version(a,b) Perl_upg_version(aTHX_ a,b)
#define vverify(a) Perl_vverify(aTHX_ a)
#define check_uni() S_check_uni(aTHX)
#define force_next(a) S_force_next(aTHX_ a)
#define force_version(a,b) S_force_version(aTHX_ a,b)
+#define force_strict_version(a) S_force_strict_version(aTHX_ a)
#define force_word(a,b,c,d,e) S_force_word(aTHX_ a,b,c,d,e)
#define tokeq(a) S_tokeq(aTHX_ a)
#define readpipe_override() S_readpipe_override(aTHX)
Perl_new_stackinfo
Perl_scan_vstring
Perl_scan_version
+Perl_prescan_version
Perl_new_version
Perl_upg_version
Perl_vverify
typedef U32 line_t;
#define NOLINE ((line_t) 4294967295UL)
+/* Helpful alias for version prescan */
+#define is_LAX_VERSION(a,b) \
+ (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
+
+#define is_STRICT_VERSION(a,b) \
+ (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
+
+#define BADVERSION(a,b,c) \
+ if (b) { \
+ *b = c; \
+ } \
+ return a;
/*
=head1 Memory Management
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';
'UNIVERSAL::VERSION' => 1,
);
}
-
+
my $callpkg = caller();
if (exists($args{declare})) {
}
}
+sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
+sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
+
1;
# 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");
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 );
#define PERL_ARGS_ASSERT_SCAN_VERSION \
assert(s); assert(rv)
+PERL_CALLCONV const char* Perl_prescan_version(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_period, int *swidth, bool *salpha)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PRESCAN_VERSION \
+ assert(s)
+
PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_NEW_VERSION \
#define PERL_ARGS_ASSERT_FORCE_VERSION \
assert(s)
+STATIC char* S_force_strict_version(pTHX_ char *s)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FORCE_STRICT_VERSION \
+ assert(s)
+
STATIC char* S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_tick)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_FORCE_WORD \
#!./perl
-print "1..22\n";
+print "1..14\n";
$blurfl = 123;
$foo = 3;
print __PACKAGE__ eq 'bug32562' ? "ok 13\n" : "not ok 13\n";
print eval '__PACKAGE__' eq 'bug32562' ? "ok 14\n" : "not ok 14\n";
-# test: package NAME VERSION
-
-my @variations = (
- '1.00',
- '1.00_01',
- 'v1.2.3',
- 'v1.2_3',
-);
-
-my $test_count = 15;
-
-for my $v ( @variations ) {
- my $ok = eval "package withversion $v; $v eq \$withversion::VERSION";
- print $ok ? "ok $test_count\n" : "not ok $test_count\n";
- $test_count++;
-}
-
-eval q/package Foo Bar/;
-$@ =~ /syntax error/ or print "not ";
-print "ok $test_count\n"; $test_count++;
-
-eval q/package Foo 1a/;
-$@ =~ /syntax error/ or print "not ";
-print "ok $test_count\n"; $test_count++;
-
-eval q/package Foo v/;
-$@ =~ /syntax error/ or print "not ";
-print "ok $test_count\n"; $test_count++;
-
-eval q/package Foo $foo/;
-$@ =~ /syntax error/ or print "not ";
-print "ok $test_count\n"; $test_count++;
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+# XXX remove this later -- dagolden, 2010-01-13
+# local *STDERR = *STDOUT;
+
+my @syntax_cases = (
+ 'package Foo',
+ 'package Bar 1.23',
+ 'package Baz v1.2.3',
+);
+
+my @version_cases = <DATA>;
+
+plan tests => 5 * @syntax_cases + 5 * grep { $_ !~ /^#/ } @version_cases;
+
+use warnings qw/syntax/;
+use version;
+
+for my $string ( @syntax_cases ) {
+ eval "$string";
+ is( $@, '', qq/eval "$string"/ );
+ eval "$string;";
+ is( $@, '', qq/eval "$string;"/ );
+ eval "$string ;";
+ is( $@, '', qq/eval "$string ;"/ );
+ eval "{$string}";
+ is( $@, '', qq/eval "{$string}"/ );
+ eval "{ $string }";
+ is( $@, '', qq/eval "{ $string }"/ );
+}
+
+LINE:
+for my $line (@version_cases) {
+ chomp $line;
+ # comments in data section are just diagnostics
+ if ($line =~ /^#/) {
+ diag $line;
+ next LINE;
+ }
+
+ my ($v, $package, $quoted, $bare, $match) = split /\t+/, $line;
+ my $warning = "";
+ local $SIG{__WARN__} = sub { $warning .= $_[0] . "\n" };
+ $match = defined $match ? $match : "";
+ $match =~ s/\s*\z//; # kill trailing spaces
+
+ # First handle the 'package NAME VERSION' case
+ $withversion::VERSION = undef;
+ if ($package eq 'fail') {
+ eval "package withversion $v";
+ like($@, qr/$match/, "package withversion $v -> syntax error ($match)");
+ ok(! version::is_strict($v), qq{... and "$v" should also fail STRICT regex});
+ }
+ else {
+ my $ok = eval "package withversion $v; $v eq \$withversion::VERSION";
+ ok($ok, "package withversion $v")
+ or diag( $@ ? $@ : "and \$VERSION = $withversion::VERSION");
+ ok( version::is_strict($v), qq{... and "$v" should pass STRICT regex});
+ }
+
+
+ # Now check the version->new("V") case
+ my $ver = undef;
+ eval qq/\$ver = version->new("$v")/;
+ if ($quoted eq 'fail') {
+ like($@, qr/$match/, qq{version->new("$v") -> invalid format ($match)})
+ or diag( $@ ? $@ : "and \$ver = $ver" );
+ ok( ! version::is_lax($v), qq{... and "$v" should fail LAX regex});
+ }
+ else {
+ is($@, "", qq{version->new("$v")});
+ ok( version::is_lax($v), qq{... and "$v" should pass LAX regex});
+ }
+
+ # Now check the version->new(V) case, unless we're skipping it
+ if ( $bare eq 'na' ) {
+ pass( "... skipping version->new($v)" );
+ next LINE;
+ }
+ $ver = undef;
+ eval qq/\$ver = version->new($v)/;
+ if ($bare eq 'fail') {
+ like($@, qr/$match/m, qq{... and unquoted version->new($v) has same error})
+ or diag( $@ ? $@ : "and \$ver = $ver" );
+ }
+ else {
+ is($@, "", qq{... and version->new($v) is ok});
+ }
+}
+
+
+# The data is organized in tab delimited format with these columns:
+#
+# value package version->new version->new regex
+# quoted unquoted
+#
+# For each value, it is tested using eval in the following expressions
+#
+# package foo $value; # column 2
+# and
+# my $ver = version->new("$value"); # column 3
+# and
+# my $ver = version->new($value); # column 4
+#
+# The second through fourth columns can contain 'pass' or 'fail'.
+#
+# For any column with 'pass', the tests makes sure that no warning/error
+# was thrown. For any column with 'fail', the tests make sure that the
+# error thrown matches the regex in the last column. The unquoted column
+# may also have 'na' indicating that it's pointless to test as behavior
+# is subject to the perl parser before a stringifiable value is available
+# to version->new
+#
+# If all columns are marked 'pass', the regex column is left empty.
+#
+# there are multiple ways that underscores can fail depending on strict
+# vs lax format so these test do not distinguish between them
+#
+# If the DATA line begins with a # mark, it is used as a diag comment
+__DATA__
+1.00 pass pass pass
+1.00001 pass pass pass
+0.123 pass pass pass
+12.345 pass pass pass
+42 pass pass pass
+0 pass pass pass
+0.0 pass pass pass
+v1.2.3 pass pass pass
+v1.2.3.4 pass pass pass
+v0.1.2 pass pass pass
+v0.0.0 pass pass pass
+01 fail pass pass no leading zeros
+01.0203 fail pass pass no leading zeros
+v01 fail pass pass no leading zeros
+v01.02.03 fail pass pass no leading zeros
+.1 fail pass pass 0 before decimal required
+.1.2 fail pass pass 0 before decimal required
+1. fail pass pass fractional part required
+1.a fail fail na fractional part required
+1._ fail fail na fractional part required
+1.02_03 fail pass pass underscore
+v1.2_3 fail pass pass underscore
+v1.02_03 fail pass pass underscore
+v1.2_3_4 fail fail fail underscore
+v1.2_3.4 fail fail fail underscore
+1.2_3.4 fail fail fail underscore
+0_ fail fail na underscore
+1_ fail fail na underscore
+1_. fail fail na underscore
+1.1_ fail fail na underscore
+1.02_03_04 fail fail na underscore
+1.2.3 fail pass pass dotted-decimal versions must begin with 'v'
+v1.2 fail pass pass dotted-decimal versions require at least three parts
+v0 fail pass pass dotted-decimal versions require at least three parts
+v1 fail pass pass dotted-decimal versions require at least three parts
+v.1.2.3 fail fail na dotted-decimal versions require at least three parts
+v fail fail na dotted-decimal versions require at least three parts
+v1.2345.6 fail pass pass maximum 3 digits between decimals
+undef fail pass pass non-numeric data
+1a fail fail na non-numeric data
+1.2a3 fail fail na non-numeric data
+bar fail fail na non-numeric data
+_ fail fail na non-numeric data
Invalid type '%c' in %s
Invalid type '%c' in unpack
Invalid type ',' in %s
+Invalid strict version format (0 before decimal required)
+Invalid strict version format (no leading zeros)
+Invalid strict version format (no underscores)
+Invalid strict version format (v1.2.3 required)
+Invalid strict version format (version required)
+Invalid strict version format (1.[0-9] required)
Invalid version format (alpha without decimal)
Invalid version format (misplaced _ in number)
Invalid version object
}
/*
+ * S_force_strict_version
+ * Forces the next token to be a version number using strict syntax rules.
+ */
+
+STATIC char *
+S_force_strict_version(pTHX_ char *s)
+{
+ dVAR;
+ OP *version = NULL;
+#ifdef PERL_MAD
+ I32 startoff = s - SvPVX(PL_linestr);
+#endif
+ const char *errstr = NULL;
+
+ PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
+
+ while (isSPACE(*s)) /* leading whitespace */
+ s++;
+
+ if (is_STRICT_VERSION(s,&errstr)) {
+ SV *ver = newSV(0);
+ s = (char *)scan_version(s, ver, 0);
+ version = newSVOP(OP_CONST, 0, ver);
+ }
+ else if ( (*s != ';' && *s != '}' ) && (s = SKIPSPACE1(s), (*s != ';' && *s !='}' ))) {
+ PL_bufptr = s;
+ if (errstr)
+ yyerror(errstr); /* version required */
+ return s;
+ }
+
+#ifdef PERL_MAD
+ if (PL_madskills && !version) {
+ sv_free(PL_nextwhite); /* let next token collect whitespace */
+ PL_nextwhite = 0;
+ s = SvPVX(PL_linestr) + startoff;
+ }
+#endif
+ /* NOTE: The parser sees the package name and the VERSION swapped */
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval = version;
+ force_next(WORD);
+
+ return s;
+}
+
+/*
* S_tokeq
* Tokenize a quoted string passed in as an SV. It finds the next
* chunk, up to end of string or a backslash. It may make a new
case KEY_package:
s = force_word(s,WORD,FALSE,TRUE,FALSE);
- s = force_version(s, FALSE);
+ s = force_strict_version(s);
OPERATOR(PACKAGE);
case KEY_pipe:
? HvNAME(SvSTASH(SvRV(ST(0))))
: (char *)SvPV_nolen(ST(0));
- if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
+ if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
/* create empty object */
vs = sv_newmortal();
- sv_setpvs(vs,"");
+ sv_setpvs(vs, "undef");
}
else if ( items == 3 ) {
vs = sv_newmortal();
if ( ! sv_derived_from(robj, "version") )
{
- robj = new_version(robj);
+ robj = new_version(SvOK(robj) ? robj : newSVpvs("undef"));
}
rvs = SvRV(robj);
SV * ver = ST(0);
SV * rv;
const char * classname = "";
- if ( items == 2 && (ST(1)) != &PL_sv_undef ) {
+ if ( items == 2 && SvOK(ST(1)) ) {
/* getting called as object or class method */
ver = ST(1);
classname =
}
#define VERSION_MAX 0x7FFFFFFF
+
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+ const char **errstr,
+ bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+ bool qv = (sqv ? *sqv : FALSE);
+ int width = 3;
+ int saw_decimal = 0;
+ bool alpha = FALSE;
+ const char *d = s;
+
+ PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+ if (qv && isDIGIT(*d))
+ goto dotted_decimal_version;
+
+ if (*d == 'v') { /* explicit v-string */
+ d++;
+ if (isDIGIT(*d)) {
+ qv = TRUE;
+ }
+ else { /* degenerate v-string */
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if (strict && d[0] == '0' && isDIGIT(d[1])) {
+ /* no leading zeros allowed */
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT(*d)) /* integer part */
+ d++;
+
+ if (*d == '.')
+ {
+ saw_decimal++;
+ d++; /* decimal point */
+ }
+ else
+ {
+ if (strict) {
+ /* require v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ int i = 0;
+ int j = 0;
+ while (isDIGIT(*d)) { /* just keep reading */
+ i++;
+ while (isDIGIT(*d)) {
+ d++; j++;
+ /* maximum 3 digits between decimal */
+ if (strict && j > 3) {
+ BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ else if (*d == '.') {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ saw_decimal++;
+ d++;
+ }
+ else if (!isDIGIT(*d)) {
+ break;
+ }
+ j = 0;
+ }
+
+ if (strict && i < 2) {
+ /* requires v1.2.3 */
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } /* end if dotted-decimal */
+ else
+ { /* decimal versions */
+ /* special strict case for leading '.' or '0' */
+ if (strict) {
+ if (*d == '.') {
+ BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+ }
+ if (*d == '0' && isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ /* consume all of the integer part */
+ while (isDIGIT(*d))
+ d++;
+
+ /* look for a fractional part */
+ if (*d == '.') {
+ /* we found it, so consume it */
+ saw_decimal++;
+ d++;
+ }
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') {
+ if ( d == s ) {
+ /* found nothing */
+ BADVERSION(s,errstr,"Invalid version format (version required)");
+ }
+ /* found just an integer */
+ goto version_prescan_finish;
+ }
+ else if ( d == s ) {
+ /* didn't find either integer or period */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+ else if (*d == '_') {
+ /* underscore can't come after integer part */
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ else if (isDIGIT(d[1])) {
+ BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ else {
+ /* anything else after integer part is just invalid data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ /* scan the fractional part after the decimal point*/
+
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) {
+ /* strict or lax-but-not-the-end */
+ BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT(*d)) {
+ d++;
+ if (*d == '.' && isDIGIT(d[-1])) {
+ if (alpha) {
+ BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+ }
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ d = (char *)s; /* start all over again */
+ qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if (*d == '_') {
+ if (strict) {
+ BADVERSION(s,errstr,"Invalid version format (no underscores)");
+ }
+ if ( alpha ) {
+ BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT(d[1]) ) {
+ BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+ }
+ d++;
+ alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE(*d))
+ d++;
+
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) {
+ /* trailing non-numeric data */
+ BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (sqv)
+ *sqv = qv;
+ if (swidth)
+ *swidth = width;
+ if (ssaw_decimal)
+ *ssaw_decimal = saw_decimal;
+ if (salpha)
+ *salpha = alpha;
+ return d;
+}
+
/*
=for apidoc scan_version
const char *start;
const char *pos;
const char *last;
- int saw_period = 0;
- int alpha = 0;
+ const char *errstr = NULL;
+ int saw_decimal = 0;
int width = 3;
+ bool alpha = FALSE;
bool vinf = FALSE;
AV * const av = newAV();
SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+
while (isSPACE(*s)) /* leading whitespace is OK */
s++;
- start = last = s;
-
- if (*s == 'v') {
- s++; /* get past 'v' */
- qv = 1; /* force quoted version processing */
- }
-
- pos = s;
-
- /* pre-scan the input string to check for decimals/underbars */
- while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
- {
- if ( *pos == '.' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
- saw_period++ ;
- last = pos;
+ last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+ if (errstr) {
+ /* "undef" is a special case and not an error */
+ if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+ Perl_croak(aTHX_ "%s", errstr);
}
- else if ( *pos == '_' )
- {
- if ( alpha )
- Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
- alpha = 1;
- width = pos - last - 1; /* natural width of sub-version */
- }
- else if ( *pos == ',' && isDIGIT(pos[1]) )
- {
- saw_period++ ;
- last = pos;
- }
-
- pos++;
}
- if ( alpha && !saw_period )
- Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
-
- if ( alpha && saw_period && width == 0 )
- Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
-
- if ( saw_period > 1 )
- qv = 1; /* force quoted version processing */
-
- last = pos;
+ start = s;
+ if (*s == 'v')
+ s++;
pos = s;
if ( qv )
* point of a version originally created with a bare
* floating point number, i.e. not quoted in any way
*/
- if ( !qv && s > start && saw_period == 1 ) {
+ if ( !qv && s > start && saw_decimal == 1 ) {
mult *= 100;
while ( s < end ) {
orev = rev;
}
else if ( s > start ) {
SV * orig = newSVpvn(start,s-start);
- if ( qv && saw_period == 1 && *start != 'v' ) {
+ if ( qv && saw_decimal == 1 && *start != 'v' ) {
/* need to insert a v to be consistent */
sv_insert(orig, 0, 0, "v", 1);
}
/* This will get reblessed later if a derived class*/
SV * const hv = newSVrv(rv, "version");
(void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
if ( SvROK(ver) )
ver = SvRV(ver);
char * const version = savepvn( (const char*)mg->mg_ptr, len);
sv_setpvn(rv,version,len);
/* this is for consistency with the pure Perl class */
- if ( *version != 'v' )
+ if ( isDIGIT(*version) )
sv_insert(rv, 0, 0, "v", 1);
Safefree(version);
}
#ifdef SvVOK
else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- qv = 1;
+ qv = TRUE;
}
#endif
else /* must be a string or something like a string */
#ifndef SvVOK
# if PERL_VERSION > 5
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */
- if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")
+ && !(*version == 'u' && strEQ(version, "undef"))
+ && (*version < '0' || *version > '9') ) {
/* may be a v-string */
SV * const nsv = sv_newmortal();
const char *nver;
const char *pos;
- int saw_period = 0;
+ int saw_decimal = 0;
sv_setpvf(nsv,"v%vd",ver);
pos = nver = savepv(SvPV_nolen(nsv));
pos++; /* skip the leading 'v' */
while ( *pos == '.' || isDIGIT(*pos) ) {
if ( *pos == '.' )
- saw_period++ ;
+ saw_decimal++ ;
pos++;
}
/* is definitely a v-string */
- if ( saw_period == 2 ) {
+ if ( saw_decimal >= 2 ) {
Safefree(version);
version = nver;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff