In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/1428a560116cc93eb46dfe5eed2a1da4f3f25e1a?hp=5ebfb99c6175ef51d7a09ed7659fc9fa6c4e5c84>
- Log -----------------------------------------------------------------
commit 1428a560116cc93eb46dfe5eed2a1da4f3f25e1a
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 27 23:38:43 2010 -0800
perldelta up to abf9167d
M pod/perldelta.pod
commit d54f8cf785fdc1f53170418da60541995cd24eef
Author: John Peacock <john.peac...@havurah-software.org>
Date: Sat Nov 27 22:05:41 2010 -0800
Bring core Perl in line with CPAN 0.86 release
Attached is a patch that bring the core Perl version code inline with
the latest CPAN release. The vast majority of changes are in code that
does not execute in core, but that makes it easier to keep the core and
CPAN changes in sync.
M lib/version.pm
M lib/version.t
M util.c
-----------------------------------------------------------------------
Summary of changes:
lib/version.pm | 8 +++++---
lib/version.t | 44 ++++++++++++++++++++++++++++++++++++++------
pod/perldelta.pod | 8 +++++++-
util.c | 53 ++++++++++++++++++++++++++++++++---------------------
4 files changed, 82 insertions(+), 31 deletions(-)
diff --git a/lib/version.pm b/lib/version.pm
index 405eb10..b07cb77 100644
--- a/lib/version.pm
+++ b/lib/version.pm
@@ -6,7 +6,7 @@ use strict;
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-$VERSION = 0.82;
+$VERSION = 0.86;
$CLASS = 'version';
@@ -157,11 +157,13 @@ sub import {
}
if (exists($args{'is_strict'})) {
- *{$callpkg.'::is_strict'} = \&version::is_strict;
+ *{$callpkg.'::is_strict'} = \&version::is_strict
+ unless defined(&{$callpkg.'::is_strict'});
}
if (exists($args{'is_lax'})) {
- *{$callpkg.'::is_lax'} = \&version::is_lax;
+ *{$callpkg.'::is_lax'} = \&version::is_lax
+ unless defined(&{$callpkg.'::is_lax'});
}
}
diff --git a/lib/version.t b/lib/version.t
index da7a5fd..23ad2c9 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -201,15 +201,15 @@ sub BaseTests {
# test illegal formats
diag "test illegal formats" unless $ENV{PERL_CORE};
- eval {$version = $CLASS->$method("1.2_3_4")};
+ eval {my $version = $CLASS->$method("1.2_3_4")};
like($@, qr/multiple underscores/,
"Invalid version format (multiple underscores)");
- eval {$version = $CLASS->$method("1.2_3.4")};
+ eval {my $version = $CLASS->$method("1.2_3.4")};
like($@, qr/underscores before decimal/,
"Invalid version format (underscores before decimal)");
- eval {$version = $CLASS->$method("1_2")};
+ eval {my $version = $CLASS->$method("1_2")};
like($@, qr/alpha without decimal/,
"Invalid version format (alpha without decimal)");
@@ -353,7 +353,7 @@ SKIP: {
ok (eval {$new_version = $CLASS->$method($version)},
"new from existing object");
ok ($new_version == $version, "class->$method($version) identical");
- $new_version = $version->$method();
+ $new_version = $version->$method(0);
isa_ok ($new_version, $CLASS );
is ($new_version, "0", "version->$method() doesn't clone");
$new_version = $version->$method("1.2.3");
@@ -480,14 +480,24 @@ SKIP: {
if $] < 5.006_000;
diag "Tests with v-strings" unless $ENV{PERL_CORE};
$version = $CLASS->$method(1.2.3);
- ok("$version" == "v1.2.3", '"$version" == 1.2.3');
+ ok("$version" eq "v1.2.3", '"$version" eq 1.2.3');
$version = $CLASS->$method(1.0.0);
$new_version = $CLASS->$method(1);
ok($version == $new_version, '$version == $new_version');
skip "version require'd instead of use'd, cannot test declare", 1
unless defined $qv_declare;
$version = &$qv_declare(1.2.3);
- ok("$version" == "v1.2.3", 'v-string initialized $qv_declare()');
+ ok("$version" eq "v1.2.3", 'v-string initialized $qv_declare()');
+ }
+
+SKIP: {
+ skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2
+ if $] lt 5.008_001;
+ diag "Tests with bare alpha v-strings" unless $ENV{PERL_CORE};
+ $version = $CLASS->$method(v1.2.3_4);
+ is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4"');
+ $version = $CLASS->$method(eval "v1.2.3_4");
+ is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4" (from eval)');
}
diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE};
@@ -690,6 +700,28 @@ EOF
my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
}
+SKIP: {
+ if ( $] < 5.006_000 ) {
+ skip 'No v-string support at all < 5.6.0', 2;
+ }
+ # https://rt.cpan.org/Ticket/Display.html?id=49348
+ my $v = $CLASS->$method("420");
+ is "$v", "420", 'Correctly guesses this is not a v-string';
+ $v = $CLASS->$method(4.2.0);
+ is "$v", 'v4.2.0', 'Correctly guess that this is a v-string';
+ }
+SKIP: {
+ if ( $] < 5.006_000 ) {
+ skip 'No v-string support at all < 5.6.0', 4;
+ }
+ # https://rt.cpan.org/Ticket/Display.html?id=50347
+ # Check that the qv() implementation does not change
+
+ ok $CLASS->$method(1.2.3) < $CLASS->$method(1.2.3.1), 'Compare 3 and 4
digit v-strings' ;
+ ok $CLASS->$method(v1.2.3) < $CLASS->$method(v1.2.3.1), 'Compare 3 and
4 digit v-strings, leaving v';
+ ok $CLASS->$method("1.2.3") < $CLASS->$method("1.2.3.1"), 'Compare 3
and 4 digit v-strings, quoted';
+ ok $CLASS->$method("v1.2.3") < $CLASS->$method("v1.2.3.1"), 'Compare 3
and 4 digit v-strings, quoted leading v';
+ }
}
1;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 65ae622..00c5a8f 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -1,7 +1,7 @@
=encoding utf8
=for comment
-This has been completed up to 2a25d7b6.
+This has been completed up to abf9167d.
=head1 NAME
@@ -389,6 +389,12 @@ C<use 6> and C<no 5> no longer leak memory.
C<eval "BEGIN{die}"> no longer leaks memory on non-threaded builds.
+=item *
+
+PerlIO no longer crashes when called recursively, e.g., from a signal
+handler. Now it just leaks memory
+L<[perl #75556]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75556>.
+
=back
=head1 Known Problems
diff --git a/util.c b/util.c
index 52554be..f3c27f9 100644
--- a/util.c
+++ b/util.c
@@ -4534,6 +4534,11 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
/*
=for apidoc prescan_version
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing. Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
=cut
*/
const char *
@@ -5067,29 +5072,35 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
#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,"_")
- && !(*version == 'u' && strEQ(version, "undef"))
- && (*version < '0' || *version > '9') ) {
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
/* may be a v-string */
- SV * const nsv = sv_newmortal();
- const char *nver;
- const char *pos;
- int saw_decimal = 0;
- sv_setpvf(nsv,"v%vd",ver);
- pos = nver = savepv(SvPV_nolen(nsv));
-
- /* scan the resulting formatted string */
- pos++; /* skip the leading 'v' */
- while ( *pos == '.' || isDIGIT(*pos) ) {
- if ( *pos == '.' )
- saw_decimal++ ;
- pos++;
- }
+ char *testv = (char *)version;
+ STRLEN tlen = len;
+ for (tlen=0; tlen < len; tlen++, testv++) {
+ /* if one of the characters is non-text assume v-string */
+ if (testv[0] < ' ') {
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_decimal = 0;
+ sv_setpvf(nsv,"v%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ pos++; /* skip the leading 'v' */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_decimal++ ;
+ pos++;
+ }
- /* is definitely a v-string */
- if ( saw_decimal >= 2 ) {
- Safefree(version);
- version = nver;
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ break;
+ }
}
}
# endif
--
Perl5 Master Repository
