X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=e2783b4e724280d95daed6e97e67cbd36aba6891;hb=19a100ff7cd2ff1e07217151f23a9dc9b3c02e72;hp=b58a1b46a96fc66dc068aed9697b8f98eb63ca01;hpb=c473feecc28308679db0cf6f8fc1f902de2584d6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index b58a1b4..e2783b4 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, 2004, 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. @@ -17,10 +18,7 @@ #include "perl.h" #ifndef PERL_MICRO -#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include -#endif - #ifndef SIG_ERR # define SIG_ERR ((Sighandler_t) -1) #endif @@ -74,7 +72,9 @@ Perl_safesysmalloc(MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -121,7 +121,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -173,7 +175,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); my_exit(1); return Nullch; } @@ -357,8 +361,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. */ @@ -972,6 +980,52 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) return sv; } +void +Perl_write_to_stderr(pTHX_ const char* message, int msglen) +{ + IO *io; + MAGIC *mg; + + if (PL_stderrgv && SvREFCNT(PL_stderrgv) + && (io = GvIO(PL_stderrgv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { + dSP; + ENTER; + SAVETMPS; + + save_re_context(); + SAVESPTR(PL_stderrgv); + PL_stderrgv = Nullgv; + + PUSHSTACKi(PERLSI_MAGIC); + + PUSHMARK(SP); + EXTEND(SP,2); + PUSHs(SvTIED_obj((SV*)io, mg)); + PUSHs(sv_2mortal(newSVpvn(message, msglen))); + PUTBACK; + call_method("PRINT", G_SCALAR); + + POPSTACK; + FREETMPS; + LEAVE; + } + else { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + int e = errno; +#endif + PerlIO *serr = Perl_error_log; + + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); + (void)PerlIO_flush(serr); +#ifdef USE_SFIO + errno = e; +#endif + } +} + OP * Perl_vdie(pTHX_ const char* pat, va_list *args) { @@ -982,6 +1036,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: curstack = %p, mainstack = %p\n", @@ -996,6 +1051,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } else message = SvPV(msv,msglen); + utf8 = SvUTF8(msv); } else { message = Nullch; @@ -1021,6 +1077,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) save_re_context(); if (message) { msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1039,6 +1096,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", thr, PL_restartop, was_in_eval, PL_top_env)); @@ -1081,6 +1139,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; if (pat) { msv = vmess(pat, args); @@ -1091,6 +1150,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) } else message = SvPV(msv,msglen); + utf8 = SvUTF8(msv); } else { message = Nullch; @@ -1116,6 +1176,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) save_re_context(); if (message) { msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1134,24 +1195,13 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } else if (!message) message = SvPVx(ERRSV, msglen); - { -#ifdef USE_SFIO - /* SFIO can really mess with your errno */ - int e = errno; -#endif - PerlIO *serr = Perl_error_log; - - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); -#ifdef USE_SFIO - errno = e; -#endif - } + write_to_stderr(message, msglen); my_failure_exit(); } @@ -1174,8 +1224,9 @@ Perl_croak_nocontext(const char *pat, ...) =for apidoc croak This is the XSUB-writer's interface to Perl's C function. -Normally use this function the same way you use the C C -function. See C. +Normally call this function the same way you call the C C +function. Calling C returns control directly to Perl, +sidestepping the normal C order of execution. See C. If you want to throw an exception object, assign the object to C<$@> and then pass C to croak(): @@ -1206,10 +1257,10 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; - IO *io; - MAGIC *mg; + I32 utf8 = 0; msv = vmess(pat, args); + utf8 = SvUTF8(msv); message = SvPV(msv, msglen); if (PL_warnhook) { @@ -1227,6 +1278,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1241,25 +1293,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) } } - /* if STDERR is tied, use it instead */ - if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - dSP; ENTER; - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - XPUSHs(sv_2mortal(newSVpvn(message, msglen))); - PUTBACK; - call_method("PRINT", G_SCALAR); - LEAVE; - return; - } - - { - PerlIO *serr = Perl_error_log; - - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); - } + write_to_stderr(message, msglen); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1277,9 +1311,8 @@ Perl_warn_nocontext(const char *pat, ...) /* =for apidoc warn -This is the XSUB-writer's interface to Perl's C function. Use this -function the same way you use the C C function. See -C. +This is the XSUB-writer's interface to Perl's C function. Call this +function the same way you call the C C function. See C. =cut */ @@ -1323,9 +1356,11 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; msv = vmess(pat, args); message = SvPV(msv, msglen); + utf8 = SvUTF8(msv); if (ckDEAD(err)) { if (PL_diehook) { @@ -1343,6 +1378,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1357,13 +1393,10 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } - { - PerlIO *serr = Perl_error_log; - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); - } + write_to_stderr(message, msglen); my_failure_exit(); } else { @@ -1382,6 +1415,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1395,11 +1429,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) return; } } - { - PerlIO *serr = Perl_error_log; - PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); - (void)PerlIO_flush(serr); - } + write_to_stderr(message, msglen); } } @@ -1505,6 +1535,7 @@ Perl_my_setenv(pTHX_ char *nam,char *val) #endif /* WIN32 || NETWARE */ +#ifndef PERL_MICRO I32 Perl_setenv_getix(pTHX_ char *nam) { @@ -1522,6 +1553,7 @@ Perl_setenv_getix(pTHX_ char *nam) } /* potential SEGV's */ return i; } +#endif /* !PERL_MICRO */ #endif /* !VMS && !EPOC*/ @@ -2192,11 +2224,10 @@ 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 */ + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif -#endif -#ifdef SA_NOCLDWAIT +#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif @@ -2232,11 +2263,10 @@ 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 defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif @@ -2978,6 +3008,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; } @@ -2985,7 +3018,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) I32 Perl_my_fflush_all(pTHX) { -#if defined(FFLUSH_NULL) +#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) return PerlIO_flush(NULL); #else # if defined(HAS__FWALK) @@ -3622,85 +3655,6 @@ Perl_getcwd_sv(pTHX_ register SV *sv) } /* -=head1 SV Manipulation Functions - -=for apidoc scan_vstring - -Returns a pointer to the next character after the parsed -vstring, as well as updating the passed in sv. - -Function must be called like - - sv = NEWSV(92,5); - s = scan_vstring(s,sv); - -The sv should already be large enough to store the vstring -passed in, for performance reasons. - -=cut -*/ - -char * -Perl_scan_vstring(pTHX_ char *s, SV *sv) -{ - char *pos = s; - char *start = s; - if (*pos == 'v') pos++; /* get past 'v' */ - while (isDIGIT(*pos) || *pos == '_') - pos++; - if (!isALPHA(*pos)) { - UV rev; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tmpend; - - if (*s == 'v') s++; /* get past 'v' */ - - sv_setpvn(sv, "", 0); - - for (;;) { - rev = 0; - { - /* this is atoi() that tolerates underscores */ - char *end = pos; - UV mult = 1; - while (--end >= s) { - UV orev; - if (*end == '_') - continue; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if (orev > rev && ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in decimal number"); - } - } -#ifdef EBCDIC - if (rev > 0x7FFFFFFF) - 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); - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) - SvUTF8_on(sv); - if (*pos == '.' && isDIGIT(pos[1])) - s = ++pos; - else { - s = pos; - break; - } - while (isDIGIT(*pos) || *pos == '_') - pos++; - } - SvPOK_on(sv); - sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); - SvRMAGICAL_on(sv); - } - return s; -} - -/* =for apidoc scan_version Returns a pointer to the next character after the parsed @@ -3709,19 +3663,21 @@ an RV. Function must be called with an already existing SV like - sv = NEWSV(92,0); - s = scan_version(s,sv); + sv = newSV(0); + s = scan_version(s,SV *sv, bool qv); Performs some preprocessing to the string to ensure that it has the correct characteristics of a version. Flags the object if it contains an underscore (which denotes this -is a beta version). +is a alpha version). The boolean qv denotes that the version +should be interpreted as if it had multiple decimals, even if +it doesn't. =cut */ char * -Perl_scan_version(pTHX_ char *s, SV *rv) +Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) { const char *start = s; char *pos = s; @@ -3749,7 +3705,10 @@ Perl_scan_version(pTHX_ char *s, SV *rv) } pos = s; - if (*pos == 'v') pos++; /* get past 'v' */ + if (*pos == 'v') { + pos++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } while (isDIGIT(*pos)) pos++; if (!isALPHA(*pos)) { @@ -3760,26 +3719,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; /* alpha 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 ( !qv && 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,25 +3788,22 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = NEWSV(92,5); - char *version; - if ( SvNOK(ver) ) /* may get too much accuracy */ - { - char tbuf[64]; - sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); - version = savepv(tbuf); - } + SV *rv = newSV(0); #ifdef SvVOK - else if ( SvVOK(ver) ) { /* already a v-string */ + if ( SvVOK(ver) ) { /* already a v-string */ + char *version; MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); + sv_setpv(rv,version); + Safefree(version); } + else { #endif - else - { - version = (char *)SvPV(ver,PL_na); + sv_setsv(rv,ver); /* make a duplicate */ +#ifdef SvVOK } - version = scan_version(version,rv); +#endif + upg_version(rv); return rv; } @@ -3852,14 +3822,29 @@ Returns a pointer to the upgraded SV. SV * Perl_upg_version(pTHX_ SV *ver) { - char *version = savepvn(SvPVX(ver),SvCUR(ver)); + char *version; + bool qv = 0; + + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepv(tbuf); + } #ifdef SvVOK - if ( SvVOK(ver) ) { /* already a v-string */ + else if ( SvVOK(ver) ) { /* already a v-string */ MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); + qv = 1; } #endif - version = scan_version(version,ver); + else /* must be a string or something like a string */ + { + STRLEN n_a; + version = savepv(SvPV(ver,n_a)); + } + (void)scan_version(version, ver, qv); + Safefree(version); return ver; } @@ -3882,7 +3867,7 @@ SV * Perl_vnumify(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = NEWSV(92,0); + SV *sv = newSV(0); if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); @@ -3892,14 +3877,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.", (int)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", (int)PERL_ABS(digit)); } if ( len == 0 ) Perl_sv_catpv(aTHX_ sv,"000"); + sv_setnv(sv, SvNV(sv)); return sv; } @@ -3921,7 +3907,7 @@ SV * Perl_vstringify(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = NEWSV(92,0); + SV *sv = newSV(0); if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); @@ -3931,19 +3917,23 @@ 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"); + + if ( len <= 2 ) { /* short version, must be at least three */ + for ( len = 2 - len; len != 0; len-- ) + Perl_sv_catpv(aTHX_ sv,".0"); + } + return sv; -} +} /* =for apidoc vcmp @@ -3971,19 +3961,38 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) { I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); - bool lbeta = left < 0 ? 1 : 0; - bool rbeta = right < 0 ? 1 : 0; + bool lalpha = left < 0 ? 1 : 0; + bool ralpha = right < 0 ? 1 : 0; left = abs(left); right = abs(right); - if ( left < right || (left == right && lbeta && !rbeta) ) + if ( left < right || (left == right && lalpha && !ralpha) ) retval = -1; - if ( left > right || (left == right && rbeta && !lbeta) ) + if ( left > right || (left == right && ralpha && !lalpha) ) retval = +1; i++; } - if ( l != r && retval == 0 ) - retval = l < r ? -1 : +1; + if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ + { + if ( l < r ) + { + while ( i <= r && retval == 0 ) + { + if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 ) + retval = -1; /* not a match after all */ + i++; + } + } + else + { + while ( i <= l && retval == 0 ) + { + if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 ) + retval = +1; /* not a match after all */ + i++; + } + } + } return retval; } @@ -4288,3 +4297,174 @@ 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; +} + +U32 +Perl_seed(pTHX) +{ + /* + * This is really just a quick hack which grabs various garbage + * values. It really should be a real hash algorithm which + * spreads the effect of every input bit onto every output bit, + * if someone who knows about such things would bother to write it. + * Might be a good idea to add that function to CORE as well. + * No numbers below come from careful analysis or anything here, + * except they are primes and SEED_C1 > 1E6 to get a full-width + * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should + * probably be bigger too. + */ +#if RANDBITS > 16 +# define SEED_C1 1000003 +#define SEED_C4 73819 +#else +# define SEED_C1 25747 +#define SEED_C4 20639 +#endif +#define SEED_C2 3 +#define SEED_C3 269 +#define SEED_C5 26107 + +#ifndef PERL_NO_DEV_RANDOM + int fd; +#endif + U32 u; +#ifdef VMS +# include + /* when[] = (low 32 bits, high 32 bits) of time since epoch + * in 100-ns units, typically incremented ever 10 ms. */ + unsigned int when[2]; +#else +# ifdef HAS_GETTIMEOFDAY + struct timeval when; +# else + Time_t when; +# endif +#endif + +/* This test is an escape hatch, this symbol isn't set by Configure. */ +#ifndef PERL_NO_DEV_RANDOM +#ifndef PERL_RANDOM_DEVICE + /* /dev/random isn't used by default because reads from it will block + * if there isn't enough entropy available. You can compile with + * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there + * is enough real entropy to fill the seed. */ +# define PERL_RANDOM_DEVICE "/dev/urandom" +#endif + fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); + if (fd != -1) { + if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) + u = 0; + PerlLIO_close(fd); + if (u) + return u; + } +#endif + +#ifdef VMS + _ckvmssts(sys$gettim(when)); + u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; +#else +# ifdef HAS_GETTIMEOFDAY + PerlProc_gettimeofday(&when,NULL); + u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; +# else + (void)time(&when); + u = (U32)SEED_C1 * when; +# endif +#endif + u += SEED_C3 * (U32)PerlProc_getpid(); + u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); +#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ + u += SEED_C5 * (U32)PTR2UV(&when); +#endif + return u; +} + +UV +Perl_get_hash_seed(pTHX) +{ + char *s = PerlEnv_getenv("PERL_HASH_SEED"); + UV myseed = 0; + + if (s) + while (isSPACE(*s)) s++; + if (s && isDIGIT(*s)) + myseed = (UV)Atoul(s); + else +#ifdef USE_HASH_SEED_EXPLICIT + if (s) +#endif + { + /* Compute a random seed */ + (void)seedDrand01((Rand_seed_t)seed()); + myseed = (UV)(Drand01() * (NV)UV_MAX); +#if RANDBITS < (UVSIZE * 8) + /* Since there are not enough randbits to to reach all + * the bits of a UV, the low bits might need extra + * help. Sum in another random number that will + * fill in the low bits. */ + myseed += + (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); +#endif /* RANDBITS < (UVSIZE * 8) */ + if (myseed == 0) { /* Superparanoia. */ + myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ + if (myseed == 0) + Perl_croak(aTHX_ "Your random numbers are not that random"); + } + } + PL_rehash_seed_set = TRUE; + + return myseed; +}