- 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 (isALPHA_FOLD_EQ(s[0], 'b')) {
- s++;
- len--;
- }
- else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) {
- s+=2;
- len-=2;
- }
- }
- }
-
- for (; len-- && (bit = *s); s++) {
- if (bit == '0' || bit == '1') {
- /* Write it in this wonky order with a goto to attempt to get the
- compiler to make the common case integer-only loop pretty tight.
- With gcc seems to be much straighter code than old scan_bin. */
- redo:
- if (!overflowed) {
- if (value <= max_div_2) {
- value = (value << 1) | (bit - '0');
- continue;
- }
- /* Bah. We're just overflowed. */
- /* diag_listed_as: Integer overflow in %s number */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in binary number");
- overflowed = TRUE;
- value_nv = (NV) value;
- }
- value_nv *= 2.0;
- /* If an NV has not enough bits in its mantissa to
- * represent a UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply value_nv by the
- * right amount. */
- value_nv += (NV)(bit - '0');
- continue;
- }
- if (bit == '_' && len && allow_underscores && (bit = s[1])
- && (bit == '0' || bit == '1'))
- {
- --len;
- ++s;
- goto redo;
- }
- if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
- Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
- "Illegal binary digit '%c' ignored", *s);
- break;
- }
-
- if ( ( overflowed && value_nv > 4294967295.0)
-#if UVSIZE > 4
- || (!overflowed && value > 0xffffffff
- && ! (*flags & PERL_SCAN_SILENT_NON_PORTABLE))
-#endif
- ) {
- Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
- "Binary number > 0b11111111111111111111111111111111 non-portable");
- }
- *len_p = s - start;
- if (!overflowed) {
- *flags = 0;
- return value;
- }
- *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
- if (result)
- *result = value_nv;
- return UV_MAX;