t/op/pos.t See if pos works
t/op/push.t See if push and pop work
t/op/pwent.t See if getpw*() functions work
+t/op/qq.t See if qq works
t/op/quotemeta.t See if quotemeta works
t/op/rand.t See if rand works
t/op/range.t See if .. works
and writes the value to I<*result> (or the value is discarded if I<result>
is NULL).
-The hex number may optinally be prefixed with "0b" or "b". If
-C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> on entry then the binary
+The hex number may optinally be prefixed with "0b" or "b" unless
+C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
+C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the binary
number may use '_' characters to separate digits.
=cut
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
- /* strip off leading b or 0b.
- for compatibility silently suffer "b" and "0b" as valid binary numbers.
- */
- if (len >= 1) {
- if (s[0] == 'b') {
- s++;
- len--;
- }
- else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
- s+=2;
- len-=2;
- }
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading b or 0b.
+ for compatibility silently suffer "b" and "0b" as valid binary
+ numbers. */
+ if (len >= 1) {
+ if (s[0] == 'b') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
+ s+=2;
+ len-=2;
+ }
+ }
}
for (; len-- && *s; s++) {
and writes the value to I<*result> (or the value is discarded if I<result>
is NULL).
-The hex number may optinally be prefixed with "0x" or "x". If
-C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> on entry then the hex
+The hex number may optinally be prefixed with "0x" or "x" unless
+C<PERL_SCAN_DISALLOW_PREFIX> is set in I<*flags> on entry. If
+C<PERL_SCAN_ALLOW_UNDERSCORES> is set in I<*flags> then the hex
number may use '_' characters to separate digits.
=cut
bool overflowed = FALSE;
const char *hexdigit;
- /* strip off leading x or 0x.
- for compatibility silently suffer "x" and "0x" as valid hex numbers. */
- if (len >= 1) {
- if (s[0] == 'x') {
- s++;
- len--;
- }
- else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
- s+=2;
- len-=2;
- }
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading x or 0x.
+ for compatibility silently suffer "x" and "0x" as valid hex numbers.
+ */
+ if (len >= 1) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
}
for (; len-- && *s; s++) {
/* Input flags: */
#define PERL_SCAN_ALLOW_UNDERSCORES 0x01 /* grok_??? accept _ in numbers */
+#define PERL_SCAN_DISALLOW_PREFIX 0x02 /* grok_??? reject 0x in hex etc */
/* Output flags: */
#define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 /* should this merge with above? */
vFAIL("Missing right brace on \\x{}");
}
else {
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
+ | PERL_SCAN_DISALLOW_PREFIX;
numlen = e - p - 1;
ender = grok_hex(p + 1, &numlen, &flags, NULL);
if (ender > 0xff)
}
}
else {
- I32 flags = 0;
+ I32 flags = PERL_SCAN_DISALLOW_PREFIX;
numlen = 2;
ender = grok_hex(p, &numlen, &flags, NULL);
p += numlen;
case 'a': value = ASCII_TO_NATIVE('\007');break;
case 'x':
if (*RExC_parse == '{') {
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
+ | PERL_SCAN_DISALLOW_PREFIX;
e = strchr(RExC_parse++, '}');
if (!e)
vFAIL("Missing right brace on \\x{}");
RExC_parse = e + 1;
}
else {
- I32 flags = 0;
+ I32 flags = PERL_SCAN_DISALLOW_PREFIX;
numlen = 2;
value = grok_hex(RExC_parse, &numlen, &flags, NULL);
RExC_parse += numlen;
$| = 1;
-print "1..686\n";
+print "1..714\n";
BEGIN {
chdir 't' if -d 't';
print "not " unless length($y) == 2 && $y eq $x;
print "ok 686\n";
}
+
+my $test = 687;
+
+# Force scalar context on the patern match
+sub ok ($$) {
+ my($ok, $name) = @_;
+
+ printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
+
+ printf "# Failed test at line %d\n", (caller)[2] unless $ok;
+
+ $test++;
+ return $ok;
+}
+
+{
+ # Check that \x## works. 5.6.1 and 5.005_03 fail some of these.
+ $x = "\x4e" . "E";
+ ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched.");
+
+ $x = "\x4e" . "i";
+ ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)");
+
+ $x = "\x4" . "j";
+ ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)");
+
+ $x = "\x0" . "k";
+ ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)");
+
+ $x = "\x0" . "x";
+ ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0");
+
+ $x = "\x0" . "xa";
+ ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa");
+
+ $x = "\x9" . "_b";
+ ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b");
+
+ print "# and now again in [] ranges\n";
+
+ $x = "\x4e" . "E";
+ ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched.");
+
+ $x = "\x4e" . "i";
+ ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)");
+
+ $x = "\x4" . "j";
+ ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)");
+
+ $x = "\x0" . "k";
+ ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)");
+
+ $x = "\x0" . "x";
+ ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0");
+
+ $x = "\x0" . "xa";
+ ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa");
+
+ $x = "\x9" . "_b";
+ ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b");
+
+}
+
+{
+ # Check that \x{##} works. 5.6.1 fails quite a few of these.
+
+ $x = "\x9b";
+ ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b");
+
+ print "# and now again in [] ranges\n";
+
+ $x = "\x9b";
+ ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{9_b}y]{2}$/, "\\x{9_b} is to be treated as \\x9b (again)");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0");
+
+ $x = "\x0" . "y";
+ ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0");
+
+ $x = "\x9b" . "y";
+ ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b");
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print q(1..21
+);
+
+# This is() function is written to avoid ""
+my $test = 1;
+sub is {
+ my($left, $right) = @_;
+
+ if ($left eq $right) {
+ printf 'ok %d
+', $test++;
+ return 1;
+ }
+ foreach ($left, $right) {
+ # Comment out these regexps to map non-printables to ord if the perl under
+ # test is so broken that it's not helping
+ s/([^-+A-Za-z_0-9])/sprintf q{'.chr(%d).'}, ord $1/ge;
+ $_ = sprintf q('%s'), $_;
+ s/^''\.//;
+ s/\.''$//;
+ }
+ printf q(not ok %d - got %s expected %s
+), $test++, $left, $right;
+
+ printf q(# Failed test at line %d
+), (caller)[2];
+
+ return 0;
+}
+
+is ("\x53", chr 83);
+is ("\x4EE", chr (78) . 'E');
+is ("\x4i", chr (4) . 'i'); # This will warn
+is ("\xh", chr (0) . 'h'); # This will warn
+is ("\xx", chr (0) . 'x'); # This will warn
+is ("\xx9", chr (0) . 'x9'); # This will warn. \x9 is tab in EBCDIC too?
+is ("\x9_E", chr (9) . '_E'); # This will warn
+
+is ("\x{4E}", chr 78);
+is ("\x{6_9}", chr 105);
+is ("\x{_6_3}", chr 99);
+is ("\x{_6B}", chr 107);
+
+is ("\x{9__0}", chr 9); # multiple underscores not allowed.
+is ("\x{77_}", chr 119); # trailing underscore warns.
+is ("\x{6FQ}z", chr (111) . 'z');
+
+is ("\x{0x4E}", chr 0);
+is ("\x{x4E}", chr 0);
+
+is ("\x{0065}", chr 101);
+is ("\x{000000000000000000000000000000000000000000000000000000000000000072}",
+ chr 114);
+is ("\x{0_06_5}", chr 101);
+is ("\x{1234}", chr 4660);
+is ("\x{98765432}", chr 2557891634);
++s;
if (*s == '{') {
char* e = strchr(s, '}');
- I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
+ PERL_SCAN_DISALLOW_PREFIX;
STRLEN len;
++s;
else {
{
STRLEN len = 2;
- I32 flags = 0;
+ I32 flags = PERL_SCAN_DISALLOW_PREFIX;
uv = grok_hex(s, &len, &flags, NULL);
s += len;
}
projects / platform / upstream / perl.git / commitdiff