Change 21004 by [EMAIL PROTECTED] on 2003/09/02 19:10:18
Integrate:
[ 20995]
Subject: [perl #23679] perl-5.8.1-RC4 perldelta typo
From: "[EMAIL PROTECTED] (via RT)" <[EMAIL PROTECTED]>
Date: 1 Sep 2003 22:11:00 -0000
Message-ID: <[EMAIL PROTECTED]>
[ 20996]
Subject: [PATCH] grok_(number|numeric_radix) added to Devel::PPPort
From: Tassilo von Parseval <[EMAIL PROTECTED]>
Date: Tue, 02 Sep 2003 11:27:19 +0200
Message-id: <[EMAIL PROTECTED]>
[ 20997]
Subject: [PATCH perlfaq6.pod] Explain \Q better
From: Mark Jason Dominus <[EMAIL PROTECTED]>
Date: Mon, 01 Sep 2003 16:19:20 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 20998]
Subject: [perl #23672] Math::BigInit POD
From: "[EMAIL PROTECTED] (via RT)" <[EMAIL PROTECTED]>
Date: 1 Sep 2003 08:47:39 -0000
Message-ID: <[EMAIL PROTECTED]>
[ 20999]
Subject: [DOCPATCH] Re: [perl #23630] problem with "used only once" warning
From: Fergal Daly <[EMAIL PROTECTED]>
Date: Tue, 2 Sep 2003 17:36:52 +0100
Message-Id: <[EMAIL PROTECTED]>
[ 21000]
Retract #20930 because of
Subject: [EMAIL PROTECTED] or before broke mp2 ithreads test
From: Stas Bekman <[EMAIL PROTECTED]>
Date: Mon, 01 Sep 2003 23:31:11 -0700
Message-ID: <[EMAIL PROTECTED]>
[ 21003]
An untie test from perlmonks-- worked in 5.6.1,
broken in 5.8.0, seems to be working again in maint,
better nail it down now.
Affected files ...
... //depot/maint-5.8/perl/ext/Devel/PPPort/Changes#4 integrate
... //depot/maint-5.8/perl/ext/Devel/PPPort/PPPort.pm#9 integrate
... //depot/maint-5.8/perl/ext/Devel/PPPort/t/test.t#4 integrate
... //depot/maint-5.8/perl/lib/Math/BigInt.pm#6 integrate
... //depot/maint-5.8/perl/op.c#39 integrate
... //depot/maint-5.8/perl/pod/perldiag.pod#39 integrate
... //depot/maint-5.8/perl/pod/perlfaq6.pod#4 integrate
... //depot/maint-5.8/perl/t/op/tie.t#8 integrate
Differences ...
==== //depot/maint-5.8/perl/ext/Devel/PPPort/Changes#4 (xtext) ====
Index: perl/ext/Devel/PPPort/Changes
--- perl/ext/Devel/PPPort/Changes#3~20830~ Fri Aug 22 05:28:15 2003
+++ perl/ext/Devel/PPPort/Changes Tue Sep 2 12:10:18 2003
@@ -1,3 +1,9 @@
+2.005 - 2nd September 2003
+
+ * Some tweaks to grok_(hex|oct|bin) to make compiler warnings
+ go away for older perls
+ * grok_number and grok_numeric_radix added
+
2.004 - 22th August 2003
* Added grok_(hex|oct|bin) and related constants
==== //depot/maint-5.8/perl/ext/Devel/PPPort/PPPort.pm#9 (text) ====
Index: perl/ext/Devel/PPPort/PPPort.pm
--- perl/ext/Devel/PPPort/PPPort.pm#8~20830~ Fri Aug 22 05:28:15 2003
+++ perl/ext/Devel/PPPort/PPPort.pm Tue Sep 2 12:10:18 2003
@@ -80,6 +80,8 @@
grok_hex
grok_oct
grok_bin
+ grok_number
+ grok_numeric_radix
gv_stashpvn(str,len,flags)
INT2PTR(type,int)
IVdf
@@ -154,7 +156,7 @@
use strict;
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
-$VERSION = "2.004";
+$VERSION = "2.005";
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw();
@@ -781,9 +783,15 @@
# define PERL_SCAN_DISALLOW_PREFIX 0x02
#endif
+#if (PERL_VERSION > 6)
+#define I32_CAST
+#else
+#define I32_CAST (I32*)
+#endif
+
#ifndef grok_hex
static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) {
- NV r = scan_hex(string, *len, len);
+ NV r = scan_hex(string, *len, I32_CAST len);
if (r > UV_MAX) {
*flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
if (result) *result = r;
@@ -798,7 +806,7 @@
#ifndef grok_oct
static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) {
- NV r = scan_oct(string, *len, len);
+ NV r = scan_oct(string, *len, I32_CAST len);
if (r > UV_MAX) {
*flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
if (result) *result = r;
@@ -813,7 +821,7 @@
#ifndef grok_bin
static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) {
- NV r = scan_bin(string, *len, len);
+ NV r = scan_bin(string, *len, I32_CAST len);
if (r > UV_MAX) {
*flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
if (result) *result = r;
@@ -826,6 +834,267 @@
_grok_bin((string), (len), (flags), (result))
#endif
+#ifndef IN_LOCALE
+# define IN_LOCALE \
+ (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#endif
+
+#ifndef IN_LOCALE_RUNTIME
+# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE_COMPILETIME
+# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#endif
+
+
+#ifndef IS_NUMBER_IN_UV
+# define IS_NUMBER_IN_UV 0x01
+# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
+# define IS_NUMBER_NOT_INT 0x04
+# define IS_NUMBER_NEG 0x08
+# define IS_NUMBER_INFINITY 0x10
+# define IS_NUMBER_NAN 0x20
+#endif
+
+#ifndef grok_numeric_radix
+# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
+
+#define grok_numeric_radix Perl_grok_numeric_radix
+
+bool
+Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+#if (PERL_VERSION >= 6)
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#else
+ /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix
+ * must manually be requested from locale.h */
+#include <locale.h>
+ struct lconv *lc = localeconv();
+ char *radix = lc->decimal_point;
+ if (radix && IN_LOCALE) {
+ STRLEN len;
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#endif /* PERL_VERSION */
+#endif /* USE_LOCALE_NUMERIC */
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif /* grok_numeric_radix */
+
+#ifndef grok_number
+
+#define grok_number Perl_grok_number
+
+int
+Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+ int sawnan = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else if (*s == 'N' || *s == 'n') {
+ /* XXX TODO: There are signaling NaNs and quiet NaNs. */
+ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++;
+ sawnan = 1;
+ } else
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (sawnan) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+#endif /* grok_number */
#endif /* _P_P_PORTABILITY_H_ */
/* End of File ppport.h */
==== //depot/maint-5.8/perl/ext/Devel/PPPort/t/test.t#4 (text) ====
Index: perl/ext/Devel/PPPort/t/test.t
--- perl/ext/Devel/PPPort/t/test.t#3~20830~ Fri Aug 22 05:28:15 2003
+++ perl/ext/Devel/PPPort/t/test.t Tue Sep 2 12:10:18 2003
@@ -103,3 +103,6 @@
grok_hex
grok_oct
grok_bin
+
+grok_number
+grok_numeric_radix
==== //depot/maint-5.8/perl/lib/Math/BigInt.pm#6 (text) ====
Index: perl/lib/Math/BigInt.pm
--- perl/lib/Math/BigInt.pm#5~20045~ Sun Jul 6 22:00:40 2003
+++ perl/lib/Math/BigInt.pm Tue Sep 2 12:10:18 2003
@@ -3053,7 +3053,8 @@
=item Input
Input values to these routines may be either Math::BigInt objects or
-strings of the form C</^\s*[+-]?[\d]+\.?[\d]*E?[+-]?[\d]*$/>.
+strings of the form C</^\s*[+-]?[\d]+\.?[\d]*E?[+-]?[\d]*$/>, or
+hexadecimal C</^\s*[+-]?[0-9a-f]+$/i>, or binary C</^\s*[+-]?[01]+$/>.
You can include one underscore between any two digits.
==== //depot/maint-5.8/perl/op.c#39 (text) ====
Index: perl/op.c
--- perl/op.c#38~20991~ Mon Sep 1 21:39:23 2003
+++ perl/op.c Tue Sep 2 12:10:18 2003
@@ -3890,8 +3890,6 @@
return o;
}
-static void const_sv_xsub(pTHX_ CV* cv);
-
/*
=for apidoc cv_undef
@@ -3915,9 +3913,8 @@
#endif /* USE_5005THREADS */
#ifdef USE_ITHREADS
- if (CvFILE(cv) && (!CvXSUB(cv) || CvXSUB(cv) == const_sv_xsub)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__
- * except when XSUB was constructed via newCONSTSUB() */
+ if (CvFILE(cv) && !CvXSUB(cv)) {
+ /* for XSUBs CvFILE point directly to static memory; __FILE__ */
Safefree(CvFILE(cv));
}
CvFILE(cv) = 0;
@@ -3984,6 +3981,8 @@
}
}
+static void const_sv_xsub(pTHX_ CV* cv);
+
/*
=head1 Optree Manipulation Functions
@@ -4447,9 +4446,6 @@
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
sv_setpv((SV*)cv, ""); /* prototype is "" */
-
- if (stash)
- CopSTASH_free(PL_curcop);
LEAVE;
==== //depot/maint-5.8/perl/pod/perldiag.pod#39 (text) ====
Index: perl/pod/perldiag.pod
--- perl/pod/perldiag.pod#38~20610~ Sun Aug 10 23:37:13 2003
+++ perl/pod/perldiag.pod Tue Sep 2 12:10:18 2003
@@ -2173,6 +2173,11 @@
again somehow to suppress the message. The C<our> declaration is
provided for this purpose.
+NOTE: This warning detects symbols that have been used only once so $c, @c,
+%c, *c, &c, sub c{}, c(), and c (the filehandle or format) are considered
+the same; if a program uses $c only once but also uses any of the others it
+will not trigger this warning.
+
=item Negative '/' count in unpack
(F) The length count obtained from a length/code unpack operation was
==== //depot/maint-5.8/perl/pod/perlfaq6.pod#4 (text) ====
Index: perl/pod/perlfaq6.pod
--- perl/pod/perlfaq6.pod#3~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq6.pod Tue Sep 2 12:10:18 2003
@@ -292,14 +292,26 @@
also that any regex special characters will be acted on unless you
precede the substitution with \Q. Here's an example:
- $string = "to die?";
- $lhs = "die?";
- $rhs = "sleep, no more";
+ $string = "Placido P. Octopus";
+ $regex = "P.";
- $string =~ s/\Q$lhs/$rhs/;
- # $string is now "to sleep no more"
+ $string =~ s/$regex/Polyp/;
+ # $string is now "Polypacido P. Octopus"
-Without the \Q, the regex would also spuriously match "di".
+Because C<.> is special in regular expressions, and can match any
+single character, the regex C<P.> here has matched the <Pl> in the
+original string.
+
+To escape the special meaning of C<.>, we use C<\Q>:
+
+ $string = "Placido P. Octopus";
+ $regex = "P.";
+
+ $string =~ s/\Q$regex/Polyp/;
+ # $string is now "Placido Polyp Octopus"
+
+The use of C<\Q> causes the <.> in the regex to be treated as a
+regular character, so that C<P.> matches a C<P> followed by a dot.
=head2 What is C</o> really for?
==== //depot/maint-5.8/perl/t/op/tie.t#8 (xtext) ====
Index: perl/t/op/tie.t
--- perl/t/op/tie.t#7~20636~ Tue Aug 12 01:58:28 2003
+++ perl/t/op/tie.t Tue Sep 2 12:10:18 2003
@@ -367,3 +367,41 @@
tie $var, 'main', \$var;
untie $var;
EXPECT
+########
+# Test case from perlmonks by runrig
+# http://www.perlmonks.org/index.pl?node_id=273490
+# "Here is what I tried. I think its similar to what you've tried
+# above. Its odd but convienient that after untie'ing you are left with
+# a variable that has the same value as was last returned from
+# FETCH. (At least on my perl v5.6.1). So you don't need to pass a
+# reference to the variable in order to set it after the untie (here it
+# is accessed through a closure)."
+use strict;
+use warnings;
+package MyTied;
+sub TIESCALAR {
+ my ($class,$code) = @_;
+ bless $code, $class;
+}
+sub FETCH {
+ my $self = shift;
+ print "Untie\n";
+ $self->();
+}
+package main;
+my $var;
+tie $var, 'MyTied', sub { untie $var; 4 };
+print "One\n";
+print "$var\n";
+print "Two\n";
+print "$var\n";
+print "Three\n";
+print "$var\n";
+EXPECT
+One
+Untie
+4
+Two
+4
+Three
+4
End of Patch.
