X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ab1d6dc2131b3ec454c1c05d2ca920772d248cc1;hb=6cfe8af5837ee4b149d08cdc2afce032abee3494;hp=64cb73811b5fb052cbb0a82660581ed002907432;hpb=f800e14d03e1bfa2cf42b86e56c0183cd5875618;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 64cb738..ab1d6dc 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,7 @@ /* util.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -357,8 +358,12 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) I32 rarest = 0; U32 frequency = 256; - if (flags & FBMcf_TAIL) + if (flags & FBMcf_TAIL) { + MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ + if (mg && mg->mg_len >= 0) + mg->mg_len++; + } s = (U8*)SvPV_force(sv, len); (void)SvUPGRADE(sv, SVt_PVBM); if (len == 0) /* TAIL might be on a zero-length string. */ @@ -1242,7 +1247,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) } /* if STDERR is tied, use it instead */ - if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) + if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { dSP; ENTER; PUSHMARK(SP); @@ -2192,9 +2197,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if defined(PERL_OLD_SIGNALS) - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ -#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) @@ -2232,9 +2236,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART -#if defined(PERL_OLD_SIGNALS) - act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ -#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) @@ -2978,6 +2981,9 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_backref: result = &PL_vtbl_backref; break; + case want_vtbl_utf8: + result = &PL_vtbl_utf8; + break; } return result; } @@ -3677,7 +3683,7 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) } #ifdef EBCDIC if (rev > 0x7FFFFFFF) - Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647"); + Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647"); #endif /* Append native character for the rev point */ tmpend = uvchr_to_utf8(tmpbuf, rev); @@ -3760,26 +3766,40 @@ Perl_scan_version(pTHX_ char *s, SV *rv) for (;;) { rev = 0; { - /* this is atoi() that delimits on underscores */ - char *end = pos; - I32 mult = 1; - if ( s < pos && s > start && *(s-1) == '_' ) { - if ( *s == '0' && *(s+1) != '0') - mult = 10; /* perl-style */ - else - mult = -1; /* beta version */ - } - while (--end >= s) { - I32 orev; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if ( abs(orev) > abs(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); - } - } - - /* Append revision */ + /* this is atoi() that delimits on underscores */ + char *end = pos; + I32 mult = 1; + I32 orev; + if ( s < pos && s > start && *(s-1) == '_' ) { + mult *= -1; /* beta version */ + } + /* the following if() will only be true after the decimal + * point of a version originally created with a bare + * floating point number, i.e. not quoted in any way + */ + if ( s > start+1 && saw_period == 1 && !saw_under ) { + mult = 100; + while ( s < end ) { + orev = rev; + rev += (*s - '0') * mult; + mult /= 10; + if ( PERL_ABS(orev) > PERL_ABS(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + s++; + } + } + else { + while (--end >= s) { + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if ( PERL_ABS(orev) > PERL_ABS(rev) ) + Perl_croak(aTHX_ "Integer overflow in version"); + } + } + } + + /* Append revision */ av_push((AV *)sv, newSViv(rev)); if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) s = ++pos; @@ -3815,7 +3835,7 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = NEWSV(92,5); + SV *rv = newSV(0); char *version; if ( SvNOK(ver) ) /* may get too much accuracy */ { @@ -3829,7 +3849,7 @@ Perl_new_version(pTHX_ SV *ver) version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); } #endif - else + else /* must be a string or something like a string */ { version = (char *)SvPV(ver,PL_na); } @@ -3892,14 +3912,15 @@ Perl_vnumify(pTHX_ SV *vs) return sv; } digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit)); + Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit)); for ( i = 1 ; i <= len ; i++ ) { digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit)); + Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit)); } if ( len == 0 ) Perl_sv_catpv(aTHX_ sv,"000"); + sv_setnv(sv, SvNV(sv)); return sv; } @@ -3931,19 +3952,19 @@ Perl_vstringify(pTHX_ SV *vs) return sv; } digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d",digit); + Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit); for ( i = 1 ; i <= len ; i++ ) { digit = SvIVX(*av_fetch((AV *)vs, i, 0)); if ( digit < 0 ) - Perl_sv_catpvf(aTHX_ sv,"_%d",-digit); + Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit); else - Perl_sv_catpvf(aTHX_ sv,".%d",digit); + Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit); } if ( len == 0 ) Perl_sv_catpv(aTHX_ sv,".0"); return sv; -} +} /* =for apidoc vcmp @@ -3973,8 +3994,8 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); bool lbeta = left < 0 ? 1 : 0; bool rbeta = right < 0 ? 1 : 0; - left = abs(left); - right = abs(right); + left = PERL_ABS(left); + right = PERL_ABS(right); if ( left < right || (left == right && lbeta && !rbeta) ) retval = -1; if ( left > right || (left == right && rbeta && !lbeta) ) @@ -3982,8 +4003,14 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) i++; } - if ( l != r && retval == 0 ) - retval = l < r ? -1 : +1; + if ( l != r && retval == 0 ) /* possible match except for trailing 0 */ + { + if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) && + !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) ) + { + retval = l < r ? -1 : +1; /* not a match after all */ + } + } return retval; } @@ -4288,3 +4315,57 @@ Perl_sv_nounlocking(pTHX_ SV *sv) { } +U32 +Perl_parse_unicode_opts(pTHX_ char **popt) +{ + char *p = *popt; + U32 opt = 0; + + if (*p) { + if (isDIGIT(*p)) { + opt = (U32) atoi(p); + while (isDIGIT(*p)) p++; + if (*p && *p != '\n' && *p != '\r') + Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } + else { + for (; *p; p++) { + switch (*p) { + case PERL_UNICODE_STDIN: + opt |= PERL_UNICODE_STDIN_FLAG; break; + case PERL_UNICODE_STDOUT: + opt |= PERL_UNICODE_STDOUT_FLAG; break; + case PERL_UNICODE_STDERR: + opt |= PERL_UNICODE_STDERR_FLAG; break; + case PERL_UNICODE_STD: + opt |= PERL_UNICODE_STD_FLAG; break; + case PERL_UNICODE_IN: + opt |= PERL_UNICODE_IN_FLAG; break; + case PERL_UNICODE_OUT: + opt |= PERL_UNICODE_OUT_FLAG; break; + case PERL_UNICODE_INOUT: + opt |= PERL_UNICODE_INOUT_FLAG; break; + case PERL_UNICODE_LOCALE: + opt |= PERL_UNICODE_LOCALE_FLAG; break; + case PERL_UNICODE_ARGV: + opt |= PERL_UNICODE_ARGV_FLAG; break; + default: + if (*p != '\n' && *p != '\r') + Perl_croak(aTHX_ + "Unknown Unicode option letter '%c'", *p); + } + } + } + } + else + opt = PERL_UNICODE_DEFAULT_FLAGS; + + if (opt & ~PERL_UNICODE_ALL_FLAGS) + Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, + (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); + + *popt = p; + + return opt; +} +