X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=2c349e25b076eb52224e6a2c7ed02f0b3272b0e8;hb=5e4ba1368e095f877f5b412f0f5761ce3fcd693d;hp=5f867aedfeb1b1bd1aa8cc602ef9f37e4e29ccd8;hpb=0453d815b8a74697ff1e5451c27aba2fe537b8e0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 5f867ae..2c349e2 100644 --- a/util.c +++ b/util.c @@ -546,7 +546,7 @@ Perl_new_collate(pTHX_ const char *newcoll) } void -perl_set_numeric_radix(void) +Perl_set_numeric_radix(pTHX) { #ifdef USE_LOCALE_NUMERIC # ifdef HAS_LOCALECONV @@ -589,7 +589,7 @@ Perl_new_numeric(pTHX_ const char *newnum) PL_numeric_name = savepv(newnum); PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); PL_numeric_local = TRUE; - perl_set_numeric_radix(); + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ @@ -618,7 +618,7 @@ Perl_set_numeric_local(pTHX) setlocale(LC_NUMERIC, PL_numeric_name); PL_numeric_standard = FALSE; PL_numeric_local = TRUE; - perl_set_numeric_radix(); + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ @@ -1363,28 +1363,36 @@ S_mess_alloc(pTHX) return sv; } -#ifdef PERL_IMPLICIT_CONTEXT +#if defined(PERL_IMPLICIT_CONTEXT) char * Perl_form_nocontext(const char* pat, ...) { dTHX; - SV *sv = mess_alloc(); + char *retval; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + retval = vform(pat, &args); va_end(args); - return SvPVX(sv); + return retval; } -#endif +#endif /* PERL_IMPLICIT_CONTEXT */ char * Perl_form(pTHX_ const char* pat, ...) { - SV *sv = mess_alloc(); + char *retval; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + retval = vform(pat, &args); va_end(args); + return retval; +} + +char * +Perl_vform(pTHX_ const char *pat, va_list *args) +{ + SV *sv = mess_alloc(); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return SvPVX(sv); } @@ -1397,24 +1405,41 @@ Perl_mess(pTHX_ const char *pat, va_list *args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; +#ifdef IV_IS_QUAD + if (PL_curcop->cop_line) + Perl_sv_catpvf(aTHX_ sv, " at %_ line %" PERL_PRId64, + GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line); +#else if (PL_curcop->cop_line) Perl_sv_catpvf(aTHX_ sv, " at %_ line %ld", GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line); +#endif if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); +#ifdef IV_IS_QUAD + Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %" PERL_PRId64, + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + line_mode ? "line" : "chunk", + (IV)IoLINES(GvIOp(PL_last_in_gv))); +#else Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %ld", PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), line_mode ? "line" : "chunk", (long)IoLINES(GvIOp(PL_last_in_gv))); +#endif } +#ifdef USE_THREADS + if (thr->tid) + Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); +#endif sv_catpv(sv, PL_dirty ? dgd : ".\n"); } return sv; } -STATIC OP * -S_do_die(pTHX_ const char* pat, va_list *args) +OP * +Perl_vdie(pTHX_ const char* pat, va_list *args) { dTHR; char *message; @@ -1481,7 +1506,7 @@ S_do_die(pTHX_ const char* pat, va_list *args) return PL_restartop; } -#ifdef PERL_IMPLICIT_CONTEXT +#if defined(PERL_IMPLICIT_CONTEXT) OP * Perl_die_nocontext(const char* pat, ...) { @@ -1489,11 +1514,11 @@ Perl_die_nocontext(const char* pat, ...) OP *o; va_list args; va_start(args, pat); - o = do_die(pat, &args); + o = vdie(pat, &args); va_end(args); return o; } -#endif +#endif /* PERL_IMPLICIT_CONTEXT */ OP * Perl_die(pTHX_ const char* pat, ...) @@ -1501,13 +1526,13 @@ Perl_die(pTHX_ const char* pat, ...) OP *o; va_list args; va_start(args, pat); - o = do_die(pat, &args); + o = vdie(pat, &args); va_end(args); return o; } -STATIC void -S_do_croak(pTHX_ const char* pat, va_list *args) +void +Perl_vcroak(pTHX_ const char* pat, va_list *args) { dTHR; char *message; @@ -1564,14 +1589,14 @@ S_do_croak(pTHX_ const char* pat, va_list *args) my_failure_exit(); } -#ifdef PERL_IMPLICIT_CONTEXT +#if defined(PERL_IMPLICIT_CONTEXT) void Perl_croak_nocontext(const char *pat, ...) { dTHX; va_list args; va_start(args, pat); - do_croak(pat, &args); + vcroak(pat, &args); /* NOTREACHED */ va_end(args); } @@ -1582,13 +1607,13 @@ Perl_croak(pTHX_ const char *pat, ...) { va_list args; va_start(args, pat); - do_croak(pat, &args); + vcroak(pat, &args); /* NOTREACHED */ va_end(args); } -STATIC void -S_do_warn(pTHX_ const char* pat, va_list *args) +void +Perl_vwarn(pTHX_ const char* pat, va_list *args) { char *message; HV *stash; @@ -1640,14 +1665,14 @@ S_do_warn(pTHX_ const char* pat, va_list *args) (void)PerlIO_flush(PerlIO_stderr()); } -#ifdef PERL_IMPLICIT_CONTEXT +#if defined(PERL_IMPLICIT_CONTEXT) void Perl_warn_nocontext(const char *pat, ...) { dTHX; va_list args; va_start(args, pat); - do_warn(pat, &args); + vwarn(pat, &args); va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1657,15 +1682,35 @@ Perl_warn(pTHX_ const char *pat, ...) { va_list args; va_start(args, pat); - do_warn(pat, &args); + vwarn(pat, &args); va_end(args); } +#if defined(PERL_IMPLICIT_CONTEXT) +void +Perl_warner_nocontext(U32 err, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); +} +#endif /* PERL_IMPLICIT_CONTEXT */ + void Perl_warner(pTHX_ U32 err, const char* pat,...) { - dTHR; va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); +} + +void +Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) +{ + dTHR; char *message; HV *stash; GV *gv; @@ -1673,10 +1718,8 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) SV *msv; STRLEN msglen; - va_start(args, pat); - msv = mess(pat, &args); + msv = mess(pat, args); message = SvPV(msv, msglen); - va_end(args); if (ckDEAD(err)) { #ifdef USE_THREADS @@ -1753,7 +1796,7 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) } #ifndef VMS /* VMS' my_setenv() is in VMS.c */ -#if !defined(WIN32) && !defined(CYGWIN32) +#if !defined(WIN32) && !defined(CYGWIN) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -1818,8 +1861,8 @@ Perl_my_setenv(pTHX_ char *nam, char *val) #endif /* PERL_USE_SAFE_PUTENV */ } -#else /* WIN32 || CYGWIN32 */ -#if defined(CYGWIN32) +#else /* WIN32 || CYGWIN */ +#if defined(CYGWIN) /* * Save environ of perl.exe, currently Cygwin links in separate environ's * for each exe/dll. Probably should be a member of impure_ptr. @@ -2175,7 +2218,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) { int p[2]; register I32 This, that; - register I32 pid; + register Pid_t pid; SV *sv; I32 doexec = strNE(cmd,"-"); I32 did_pipes = 0; @@ -2246,7 +2289,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #endif /* defined OS2 */ /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + sv_setiv(GvSV(tmpgv), getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -2278,10 +2321,11 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) break; n += n1; } + PerlLIO_close(pp[0]); + did_pipes = 0; if (n) { /* Error */ if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); - PerlLIO_close(pp[0]); errno = errkid; /* Propagate errno from kid */ return Nullfp; } @@ -2467,8 +2511,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Sigsave_t hstat, istat, qstat; int status; SV **svp; - int pid; - int pid2; + Pid_t pid; + Pid_t pid2; bool close_failed; int saved_errno; #ifdef VMS @@ -2479,7 +2523,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #endif svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); - pid = (int)SvIVX(*svp); + pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; #ifdef OS2 @@ -2516,9 +2560,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif /* !DOSISH */ -#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32) +#if !defined(DOSISH) || defined(OS2) || defined(WIN32) I32 -Perl_wait4pid(pTHX_ int pid, int *statusp, int flags) +Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { SV *sv; SV** svp; @@ -2578,7 +2622,7 @@ Perl_wait4pid(pTHX_ int pid, int *statusp, int flags) void /*SUPPRESS 590*/ -Perl_pidgone(pTHX_ int pid, int status) +Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; char spid[TYPE_CHARS(int)]; @@ -2745,90 +2789,203 @@ Perl_same_dirent(pTHX_ char *a, char *b) } #endif /* !HAS_RENAME */ -UV +NV 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') { - dTHR; - register UV n = retval << 1; - if (!overflowed && (n >> 1) != retval && ckWARN_d(WARN_UNSAFE)) { - Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number"); - overflowed = TRUE; - } - retval = n | (*s++ - '0'); - len--; - } - if (len && (*s >= '2' && *s <= '9')) { - dTHR; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s); + register NV rnv = 0.0; + register UV ruv = 0; + register bool seenb = FALSE; + register bool overflowed = FALSE; + + for (; len-- && *s; s++) { + if (!(*s == '0' || *s == '1')) { + if (*s == '_') + continue; /* Note: does not check for __ and the like. */ + if (seenb == FALSE && *s == 'b' && ruv == 0) { + /* Disallow 0bbb0b0bbb... */ + seenb = TRUE; + continue; + } + else { + dTHR; + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal binary digit '%c' ignored", *s); + break; + } + } + if (!overflowed) { + register UV xuv = ruv << 1; + + if ((xuv >> 1) != ruv) { + dTHR; + overflowed = TRUE; + rnv = (NV) ruv; + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in binary number"); + } else + ruv = xuv | (*s - '0'); + } + if (overflowed) { + rnv *= 2; + /* If an NV has not enough bits in its mantissa to + * represent an 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 rnv by the + * right amount. */ + rnv += (*s - '0'); + } + } + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UV_SIZEOF > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Binary number > 0b11111111111111111111111111111111 non-portable"); } *retlen = s - start; - return retval; + return rnv; } -UV + +NV Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) { register char *s = start; - register UV retval = 0; - bool overflowed = FALSE; + register NV rnv = 0.0; + register UV ruv = 0; + register bool overflowed = FALSE; + + for (; len-- && *s; s++) { + if (!(*s >= '0' && *s <= '7')) { + if (*s == '_') + continue; /* Note: does not check for __ and the like. */ + else { + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (*s == '8' || *s == '9') { + dTHR; + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal octal digit '%c' ignored", *s); + } + break; + } + } + if (!overflowed) { + register UV xuv = ruv << 3; - while (len && *s >= '0' && *s <= '7') { - dTHR; - register UV n = retval << 3; - if (!overflowed && (n >> 3) != retval && ckWARN_d(WARN_UNSAFE)) { - Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number"); - overflowed = TRUE; + if ((xuv >> 3) != ruv) { + dTHR; + overflowed = TRUE; + rnv = (NV) ruv; + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in octal number"); + } else + ruv = xuv | (*s - '0'); + } + if (overflowed) { + rnv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent an 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 rnv by the + * right amount of 8-tuples. */ + rnv += (NV)(*s - '0'); } - retval = n | (*s++ - '0'); - len--; } - if (len && (*s == '8' || *s == '9')) { + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UV_SIZEOF > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { dTHR; - if (ckWARN(WARN_OCTAL)) - Perl_warner(aTHX_ WARN_OCTAL, "Illegal octal digit '%c' ignored", *s); + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Octal number > 037777777777 non-portable"); } *retlen = s - start; - return retval; + return rnv; } -UV +NV 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; - - while (len-- && *s) { - tmp = strchr((char *) PL_hexdigit, *s++); - if (!tmp) { - if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0)) + register NV rnv = 0.0; + register UV ruv = 0; + register bool seenx = FALSE; + register bool overflowed = FALSE; + char *hexdigit; + + for (; len-- && *s; s++) { + hexdigit = strchr((char *) PL_hexdigit, *s); + if (!hexdigit) { + if (*s == '_') + continue; /* Note: does not check for __ and the like. */ + if (seenx == FALSE && *s == 'x' && ruv == 0) { + /* Disallow 0xxx0x0xxx... */ + seenx = TRUE; continue; + } else { dTHR; - --s; - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE,"Illegal hex digit '%c' ignored", *s); + if (ckWARN(WARN_DIGIT)) + Perl_warner(aTHX_ WARN_DIGIT, + "Illegal hexadecimal digit '%c' ignored", *s); break; } } - n = retval << 4; - { - dTHR; - if (!overflowed && (n >> 4) != retval && ckWARN_d(WARN_UNSAFE)) { - Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hex number"); - overflowed = TRUE; - } + if (!overflowed) { + register UV xuv = ruv << 4; + + if ((xuv >> 4) != ruv) { + dTHR; + overflowed = TRUE; + rnv = (NV) ruv; + if (ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in hexadecimal number"); + } else + ruv = xuv | ((hexdigit - PL_hexdigit) & 15); + } + if (overflowed) { + rnv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent an 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 rnv by the + * right amount of 16-tuples. */ + rnv += (NV)((hexdigit - PL_hexdigit) & 15); } - retval = n | ((tmp - PL_hexdigit) & 15); + } + if (!overflowed) + rnv = (NV) ruv; + if ( ( overflowed && rnv > 4294967295.0) +#if UV_SIZEOF > 4 + || (!overflowed && ruv > 0xffffffff ) +#endif + ) { + dTHR; + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "Hexadecimal number > 0xffffffff non-portable"); } *retlen = s - start; - return retval; + return rnv; } char* @@ -3182,7 +3339,7 @@ Perl_condpair_magic(pTHX_ SV *sv) struct perl_thread * Perl_new_struct_thread(pTHX_ struct perl_thread *t) { -#ifndef PERL_IMPLICIT_CONTEXT +#if !defined(PERL_IMPLICIT_CONTEXT) struct perl_thread *thr; #endif SV *sv; @@ -3206,12 +3363,13 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) Zero(thr, 1, struct perl_thread); #endif - PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); + PL_protect = MEMBER_TO_FPTR(Perl_default_protect); thr->oursv = sv; init_stacks(); PL_curcop = &PL_compiling; + thr->interp = t->interp; thr->cvcache = newHV(); thr->threadsv = newAV(); thr->specific = newAV(); @@ -3238,11 +3396,11 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_statname = NEWSV(66,0); PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags); - PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start); - PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string); - PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree); + PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); + PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); + PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); + PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); + PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); PL_regindent = 0; PL_reginterp_cnt = 0; PL_lastscream = Nullsv; @@ -3250,6 +3408,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_screamnext = 0; PL_reg_start_tmp = 0; PL_reg_start_tmpl = 0; + PL_reg_poscache = Nullch; /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex);