diff options
| -rw-r--r-- | pod/perldelta.pod | 4 | ||||
| -rw-r--r-- | pod/perldiag.pod | 69 | ||||
| -rw-r--r-- | pod/perllexwarn.pod | 16 | ||||
| -rw-r--r-- | pp.c | 16 | ||||
| -rwxr-xr-x | t/op/oct.t | 44 | ||||
| -rw-r--r-- | t/pragma/warn/6default | 11 | ||||
| -rw-r--r-- | t/pragma/warn/util | 55 | ||||
| -rw-r--r-- | toke.c | 15 | ||||
| -rw-r--r-- | util.c | 123 |
9 files changed, 228 insertions, 125 deletions
diff --git a/pod/perldelta.pod b/pod/perldelta.pod index dc697e6929..0f19dbf55f 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -106,6 +106,10 @@ C<oct()>: $answer = 0b101010; printf "The answer is: %b\n", oct("0b101010"); +=head2 Too large hexadecimal, octal, and binary constants more serious + +Too large hexadecimal, octal, and binary constants now cause fatal errors. + =head2 syswrite() ease-of-use The length argument of C<syswrite()> is now optional. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 646355fe81..7d27fc29f6 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -467,6 +467,21 @@ already occurred. Since the intended environment for the C<BEGIN {}> could not be guaranteed (due to the errors), and since subsequent code likely depends on its correct operation, Perl just gave up. +=item Binary number > 0b11111111111111111111111111111111 non-portable + +(W) The binary number you specified is larger than 2**32-1 and +therefore non-portable between systems. If you know that your code is +always going to be used only in systems that have more than 32-bit +integers (which means that Perl should be able to use such), you can +silence this warning by + + { + no warning 'unsafe'; + .... your code here ... + } + +See also L<perlport> for writing portable code. + =item bind() on closed fd (W) You tried to do a bind on a closed socket. Did you forget to check @@ -1414,6 +1429,21 @@ an emergency basis to prevent a core dump. (D) Really old Perl let you omit the % on hash names in some spots. This is now heavily deprecated. +=item Hexadecimal number > 0xffffffff non-portable + +(W) The hexadecimal number you specified is larger than 2**32-1 and +therefore non-portable between systems. If you know that your code is +always going to be used only in systems that have more than 32-bit +integers (which means that Perl should be able to use such), you can +silence this warning by + + { + no warning 'unsafe'; + .... your code here ... + } + +See also L<perlport> for writing portable code. + =item Identifier too long (F) Perl limits identifiers (names for variables, functions, etc.) to @@ -1483,8 +1513,8 @@ of the octal number stopped before the 8 or 9. =item Illegal hexadecimal digit %s ignored -(W) You may have tried to use a character other than 0 - 9 or A - F in a -hexadecimal number. Interpretation of the hexadecimal number stopped +(W) You may have tried to use a character other than 0 - 9 or A - F, a - f +in a hexadecimal number. Interpretation of the hexadecimal number stopped before the illegal character. =item Illegal switch in PERL5OPT: %s @@ -1528,14 +1558,18 @@ known value, using trustworthy data. See L<perlsec>. =item Integer overflow in %s number -(S) The literal hexadecimal, octal or binary number you have specified -is too big for your architecture. On a 32-bit architecture the largest -literal hex, octal or binary number representable without overflow -is 0xFFFFFFFF, 037777777777, or 0b11111111111111111111111111111111 -respectively. Note that Perl transparently promotes decimal literals -to a floating point representation internally--subject to loss of -precision errors in subsequent operations--so this limit usually -doesn't apply to decimal literals. +(F,X) The hexadecimal, octal or binary number you have specified +either as a literal in your code or as a scalar is too big for your +architecture. On a 32-bit architecture the largest literal hex, octal +or binary number representable without overflow is 0xFFFFFFFF, +037777777777, or 0b11111111111111111111111111111111 respectively. +Note that Perl transparently promotes decimal literals to a floating +point representation internally--subject to loss of precision errors +in subsequent operations--so this limit usually doesn't apply to +decimal literals. If the overflow is in a literal of your code, the +error is untrappable (there is no way the code could work safely in +your system), if the overflow happens in hex() or oct() the error is +trappable. =item Internal inconsistency in tracking vforks @@ -1960,6 +1994,21 @@ about 250 characters. You've exceeded that length. Future versions of Perl are likely to eliminate this arbitrary limitation. In the meantime, try using scientific notation (e.g. "1e6" instead of "1_000_000"). +=item Octal number > 037777777777 non-portable + +(W) The octal number you specified is larger than 2**32-1 and +therefore non-portable between systems. If you know that your code is +always going to be used only in systems that have more than 32-bit +integers (which means that Perl should be able to use such), you can +silence this warning by + + { + no warning 'unsafe'; + .... your code here ... + } + +See also L<perlport> for writing portable code. + =item Odd number of elements in hash assignment (S) You specified an odd number of elements to initialize a hash, which diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod index 11947550c5..484e211000 100644 --- a/pod/perllexwarn.pod +++ b/pod/perllexwarn.pod @@ -50,11 +50,12 @@ warnings: mandatory and optional. As its name suggests, if your code tripped a mandatory warning, you would get a warning whether you wanted it or not. -For example, the code below would always produce an C<"integer overflow"> -warning. +For example, the code below would always produce an C<"isn't numeric"> +warning about the "2:". - my $a = oct "777777777777777777777777777777777777" ; + my $a = "2:" + 3; +though the result will be 5. With the introduction of lexical warnings, mandatory warnings now become I<default> warnings. The difference is that although the previously @@ -63,9 +64,9 @@ subsequently enabled or disabled with the lexical warning pragma. For example, in the code below, an C<"integer overflow"> warning will only be reported for the C<$a> variable. - my $a = oct "777777777777777777777777777777777777" ; + my $a = "2:" + 3; no warning ; - my $b = oct "777777777777777777777777777777777777" ; + my $b = "2:" + 3; Note that neither the B<-w> flag or the C<$^W> can be used to disable/enable default warnings. They are still mandatory in this case. @@ -206,7 +207,7 @@ to change. =head2 Category Hierarchy -A tentative hierarchy of "categories" have been defined to allow groups +A B<tentative> hierarchy of "categories" have been defined to allow groups of warnings to be enabled/disabled in isolation. The current hierarchy is: @@ -312,6 +313,9 @@ The experimental features need bottomed out. around the limitations of C<$^W>. Now that those limitations are gone, the module should be revisited. + octal + 'octal' controls illegal octal characters warning but 'unsafe' + illegal hexadecimal and binary characters warning. =head1 SEE ALSO @@ -1885,7 +1885,7 @@ PP(pp_hex) STRLEN n_a; tmps = POPpx; - XPUSHu(scan_hex(tmps, 99, &argtype)); + XPUSHu(scan_hex(tmps, sizeof(UV) * 2 + 1, &argtype)); RETURN; } @@ -1900,14 +1900,14 @@ PP(pp_oct) tmps = POPpx; while (*tmps && isSPACE(*tmps)) tmps++; - if (*tmps == '0') - tmps++; - if (*tmps == 'x') - value = scan_hex(++tmps, 99, &argtype); - else if (*tmps == 'b') - value = scan_bin(++tmps, 99, &argtype); + /* Do not eat the leading 0[bx] because we need them + * to detect malformed binary and hexadecimal numbers. */ + if ((tmps[0] == '0' && tmps[1] == 'x') || tmps[0] == 'x') + value = scan_hex(tmps, sizeof(UV) * 2 + 1, &argtype); + else if ((tmps[0] == '0' && tmps[1] == 'b') || tmps[0] == 'b') + value = scan_bin(tmps, sizeof(UV) * 8 + 1, &argtype); else - value = scan_oct(tmps, 99, &argtype); + value = scan_oct(tmps, sizeof(UV) * 4 + 1, &argtype); XPUSHu(value); RETURN; } diff --git a/t/op/oct.t b/t/op/oct.t index 06bf8db660..c0613a92bf 100755 --- a/t/op/oct.t +++ b/t/op/oct.t @@ -1,15 +1,33 @@ #!./perl -print "1..11\n"; - -print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; -print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; -print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n"; -print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n"; -print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; -print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; -print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; -print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; -print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n"; -print +(oct('b11100') == 28) ? "ok" : "not ok", " 10\n"; -print +(oct('b101010') == 0b101010) ? "ok" : "not ok", " 11\n"; +print "1..24\n"; + +print +(oct('0b10101') == 0b10101) ? "ok" : "not ok", " 1\n"; +print +(oct('0b10101') == 025) ? "ok" : "not ok", " 2\n"; +print +(oct('0b10101') == 21) ? "ok" : "not ok", " 3\n"; +print +(oct('0b10101') == 0x15) ? "ok" : "not ok", " 4\n"; + +print +(oct('b10101') == 0b10101) ? "ok" : "not ok", " 5\n"; +print +(oct('b10101') == 025) ? "ok" : "not ok", " 6\n"; +print +(oct('b10101') == 21) ? "ok" : "not ok", " 7\n"; +print +(oct('b10101') == 0x15) ? "ok" : "not ok", " 8\n"; + +print +(oct('01234') == 0b1010011100) ? "ok" : "not ok", " 9\n"; +print +(oct('01234') == 01234) ? "ok" : "not ok", " 10\n"; +print +(oct('01234') == 668) ? "ok" : "not ok", " 11\n"; +print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; + +print +(oct('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 13\n"; +print +(oct('0x1234') == 011064) ? "ok" : "not ok", " 14\n"; +print +(oct('0x1234') == 4660) ? "ok" : "not ok", " 15\n"; +print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 16\n"; + +print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 17\n"; +print +(hex('01234') == 011064) ? "ok" : "not ok", " 18\n"; +print +(hex('01234') == 4660) ? "ok" : "not ok", " 19\n"; +print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 20\n"; + +print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 21\n"; +print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 22\n"; +print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 23\n"; +print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 24\n"; diff --git a/t/pragma/warn/6default b/t/pragma/warn/6default index c095b20827..be45c77777 100644 --- a/t/pragma/warn/6default +++ b/t/pragma/warn/6default @@ -11,24 +11,23 @@ Integer overflow in octal number at - line 3. no warning ; my $a = oct "7777777777777777777777777777777777779" ; EXPECT +Integer overflow in octal number at - line 3. ######## # all warning should be displayed use warning ; -my $a = oct "7777777777777777777777777777777777779" ; +my $a = oct "77777777797"; EXPECT -Integer overflow in octal number at - line 3. Illegal octal digit '9' ignored at - line 3. ######## # check scope use warning ; -my $a = oct "7777777777777777777777777777777777779" ; +my $a = oct "77777777797"; { no warning ; - my $a = oct "7777777777777777777777777777777777779" ; + my $b = oct "77777777797"; } my $c = oct "7777777777777777777777777777777777779" ; EXPECT -Integer overflow in octal number at - line 3. Illegal octal digit '9' ignored at - line 3. +Octal number > 037777777777 non-portable at - line 8. Integer overflow in octal number at - line 8. -Illegal octal digit '9' ignored at - line 8. diff --git a/t/pragma/warn/util b/t/pragma/warn/util index fc1e6dde3f..87d43e8ffc 100644 --- a/t/pragma/warn/util +++ b/t/pragma/warn/util @@ -3,7 +3,7 @@ Illegal octal digit ignored my $a = oct "029" ; - Illegal hex digit ignored + Illegal hexadecimal digit ignored my $a = hex "0xv9" ; Illegal binary digit ignored @@ -21,7 +21,7 @@ __END__ use warning 'octal' ; my $a = oct "029" ; no warning 'octal' ; -my $a = oct "029" ; +my $b = oct "029" ; EXPECT Illegal octal digit '9' ignored at - line 3. ######## @@ -42,62 +42,47 @@ EXPECT Illegal binary digit '9' ignored at - line 3. ######## # util.c -BEGIN { require Config ; import Config } -$^W =1 ; +$^W = 1 ; sub make_bin { "1" x $_[0] } -my $s = $Config{longsize}; -eval { pack "q", 0 }; eval { $s = length pack "q", 0 } unless $@; -$n = make_bin(8 * $s ) ; -$o = make_bin(8 * $s + 1) ; +$n = make_bin(33); { use warning 'unsafe' ; my $a = oct "0b$n" ; - my $b = oct "0b$o" ; no warning 'unsafe' ; - $b = oct "0b$o" ; + my $b = oct "0b$n" ; } -my $b = oct "0b$o" ; +my $c = oct "0b$n" ; EXPECT -Integer overflow in binary number at - line 12. -Integer overflow in binary number at - line 16. +Binary number > 0b11111111111111111111111111111111 non-portable at - line 7. +Binary number > 0b11111111111111111111111111111111 non-portable at - line 11. ######## # util.c -BEGIN { require Config ; import Config } -$^W =1 ; +$^W = 1 ; sub make_oct { ("","1","3")[$_[0]%3] . "7" x int($_[0]/3) } -my $s = $Config{longsize}; -eval { pack "q", 0 }; eval { $s = length pack "q", 0 } unless $@; -$n = make_oct(8 * $s ); -$o = make_oct(8 * $s + 1); +$n = make_oct(33); { use warning 'unsafe' ; my $a = oct "$n" ; - my $b = oct "$o" ; no warning 'unsafe' ; - $b = oct "$o" ; + my $b = oct "$n" ; } -my $b = oct "$o" ; +my $c = oct "$n" ; EXPECT -Integer overflow in octal number at - line 12. -Integer overflow in octal number at - line 16. +Octal number > 037777777777 non-portable at - line 7. +Octal number > 037777777777 non-portable at - line 11. ######## # util.c -BEGIN { require Config ; import Config } -$^W =1 ; +$^W = 1 ; sub make_hex { ("","1","3","7")[$_[0]%4] . "f" x int($_[0]/4) } -my $s = $Config{longsize}; -eval { pack "q", 0 }; eval { $s = length pack "q", 0 } unless $@; -$n = make_hex(8 * $s ) ; -$o = make_hex(8 * $s + 1) ; +$n = make_hex(33); { use warning 'unsafe' ; my $a = hex "$n" ; - my $b = hex "$o" ; no warning 'unsafe' ; - $b = hex "$o" ; + my $b = hex "$n" ; } -my $b = hex "$o" ; +my $c = hex "$n" ; EXPECT -Integer overflow in hexadecimal number at - line 12. -Integer overflow in hexadecimal number at - line 16. +Hexadecimal number > 0xffffffff non-portable at - line 7. +Hexadecimal number > 0xffffffff non-portable at - line 11. @@ -871,7 +871,6 @@ S_scan_const(pTHX_ char *start) I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF)) : UTF; - /* leaveit is the set of acceptably-backslashed characters */ char *leaveit = PL_lex_inpat @@ -1074,7 +1073,6 @@ S_scan_const(pTHX_ char *start) d = (char*)uv_to_utf8((U8*)d, scan_hex(s + 1, e - s - 1, &len)); s = e + 1; - } else { UV uv = (UV)scan_hex(s, 2, &len); @@ -5978,7 +5976,6 @@ Perl_scan_num(pTHX_ char *start) dTHR; UV u; I32 shift; - bool overflowed = FALSE; /* check for hex */ if (s[1] == 'x') { @@ -6045,15 +6042,13 @@ Perl_scan_num(pTHX_ char *start) digit: n = u << shift; /* make room for the digit */ - if (!overflowed && (n >> shift) != u + if ((n >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, - "Integer overflow in %s number", - (shift == 4) ? "hex" - : ((shift == 3) ? "octal" : "binary")); - overflowed = TRUE; + Perl_croak(aTHX_ + "Integer overflow in %s number", + (shift == 4) ? "hexadecimal" + : ((shift == 3) ? "octal" : "binary")); } u = n | b; /* add the digit to the end */ break; @@ -2781,23 +2781,42 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; register UV retval = 0; - bool overflowed = FALSE; - while (len && *s >= '0' && *s <= '1') { - register UV n = retval << 1; - if (!overflowed && (n >> 1) != retval) { - dTHR; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number"); - overflowed = TRUE; + register UV n; + register I32 d = 0; + register bool seenb = FALSE; + register bool overflow = FALSE; + + for (; len-- && *s; s++) { + if (!(*s == '0' || *s == '1')) { + if (*s == '_') + continue; + if (seenb == FALSE && *s == 'b' && retval == 0) { + /* Disallow 0bbb0b0bbb... */ + seenb = TRUE; + d = 0; /* Forget any leading zeros before the 'b'. */ + continue; + } + else { + dTHR; + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, + "Illegal binary digit '%c' ignored", *s); + break; + } } - retval = n | (*s++ - '0'); - len--; + n = retval << 1; + overflow |= (n >> 1) != retval; + retval = n | (*s - '0'); + d++; } - if (len && (*s >= '2' && *s <= '9')) { - dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s); + if (sizeof(UV) > 4 && d > 32) { + dTHR; + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, + "Binary number > 0b11111111111111111111111111111111 non-portable"); } + if (overflow) + Perl_croak(aTHX_ "Integer overflow in binary number"); *retlen = s - start; return retval; } @@ -2806,24 +2825,41 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; register UV retval = 0; - bool overflowed = FALSE; - - while (len && *s >= '0' && *s <= '7') { - register UV n = retval << 3; - if (!overflowed && (n >> 3) != retval) { - dTHR; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number"); - overflowed = TRUE; + register UV n; + register I32 d = 0; + register bool seeno = FALSE; + register bool overflow = FALSE; + + for (; len-- && *s; s++) { + if (!(*s >= '0' && *s <= '7')) { + if (*s == '_') + continue; + else { + /* Allow \octal to work DWIM way (that is, stop scanning + * as soon as non-octal characters seen, complain only iff + * someone seems to want to use the eight and nine. */ + if (*s == '8' || *s == '9') { + dTHR; + if (ckWARN(WARN_OCTAL)) + Perl_warner(aTHX_ WARN_OCTAL, + "Illegal octal digit '%c' ignored", *s); + } + break; + } } - retval = n | (*s++ - '0'); - len--; + n = retval << 3; + overflow |= (n >> 3) != retval; + retval = n | (*s - '0'); + d++; } - if (len && (*s == '8' || *s == '9')) { + if (sizeof(UV) > 4 && d > 10 && (retval >> 30) > 3) { dTHR; - if (ckWARN(WARN_OCTAL)) - Perl_warner(aTHX_ WARN_OCTAL, "Illegal octal digit '%c' ignored", *s); + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, + "Octal number > 037777777777 non-portable"); } + if (overflow) + Perl_croak(aTHX_ "Integer overflow in octal number"); *retlen = s - start; return retval; } @@ -2833,32 +2869,45 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; register UV retval = 0; - bool overflowed = FALSE; char *tmp = s; register UV n; + register I32 d = 0; + register bool seenx = FALSE; + register bool overflow = FALSE; while (len-- && *s) { tmp = strchr((char *) PL_hexdigit, *s++); if (!tmp) { - if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0)) + if (*(s-1) == '_') continue; + if (seenx == FALSE && *(s-1) == 'x' && retval == 0) { + /* Disallow 0xxx0x0xxx... */ + seenx = TRUE; + d = 0; /* Forget any leading zeros before the 'x'. */ + continue; + } else { dTHR; --s; if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE,"Illegal hexadecimal digit '%c' ignored", *s); + Perl_warner(aTHX_ WARN_UNSAFE, + "Illegal hexadecimal digit '%c' ignored", *s); break; } } + d++; n = retval << 4; - if (!overflowed && (n >> 4) != retval) { - dTHR; - if (ckWARN_d(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hexadecimal number"); - overflowed = TRUE; - } + overflow |= (n >> 4) != retval; retval = n | ((tmp - PL_hexdigit) & 15); } + if (sizeof(UV) > 4 && d > 8) { + dTHR; + if (ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, + "Hexadecimal number > 0xffffffff non-portable"); + } + if (overflow) + Perl_croak(aTHX_ "Integer overflow in hexadecimal number"); *retlen = s - start; return retval; } |