X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=e24a81d19f4b00806803d4bd06a0a4cc96b215f2;hb=f970e606dd5249e7f15150b8baa7b8abd0904e24;hp=0cb5c3074e7b68df8c78e14a2030376a83abe3bb;hpb=47dafe4d9a4e294fab4b6131bb296dc386e0dcbc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 0cb5c30..e24a81d 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -26,11 +26,6 @@ #endif #endif -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include -#endif - #ifdef I_VFORK # include #endif @@ -115,7 +110,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ -#ifdef HAS_64K_LIMIT +#ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(Perl_error_log, "Reallocation too large: %lx\n", size) FLUSH; @@ -135,7 +130,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #endif ptr = (Malloc_t)PerlMem_realloc(where,size); PERL_ALLOC_CHECK(ptr); - + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); @@ -245,12 +240,12 @@ Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) if (!wh) return safexmalloc(0,size); - + { MEM_SIZE old = sizeof_chunk(where - ALIGN); int t = typeof_chunk(where - ALIGN); register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); - + xycount[t][SIZE_TO_Y(old)]--; xycount[t][SIZE_TO_Y(size)]++; xcount[t] += size - old; @@ -265,7 +260,7 @@ Perl_safexfree(Malloc_t wh) I32 x; char *where = (char*)wh; MEM_SIZE size; - + if (!where) return; where -= ALIGN; @@ -297,7 +292,7 @@ S_xstat(pTHX_ int flag) for (j = 0; j < MAXYCOUNT; j++) { subtot[j] = 0; } - + PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); for (i = 0; i < MAXXCOUNT; i++) { total += xcount[i]; @@ -306,21 +301,21 @@ S_xstat(pTHX_ int flag) } if (flag == 0 ? xcount[i] /* Have something */ - : (flag == 2 + : (flag == 2 ? xcount[i] != lastxcount[i] /* Changed */ : xcount[i] > lastxcount[i])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, + PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); lastxcount[i] = xcount[i]; for (j = 0; j < MAXYCOUNT; j++) { - if ( flag == 0 + if ( flag == 0 ? xycount[i][j] /* Have something */ - : (flag == 2 + : (flag == 2 ? xycount[i][j] != lastxycount[i][j] /* Changed */ : xycount[i][j] > lastxycount[i][j])) { /* Growed */ - PerlIO_printf(Perl_debug_log,"%3ld ", - flag == 2 - ? xycount[i][j] - lastxycount[i][j] + PerlIO_printf(Perl_debug_log,"%3ld ", + flag == 2 + ? xycount[i][j] - lastxycount[i][j] : xycount[i][j]); lastxycount[i][j] = xycount[i][j]; } else { @@ -514,7 +509,7 @@ S_stdize_locale(pTHX_ char *locs) if (u[1] == 0) { STRLEN len = u - s; - Move(t + 1, locs, len, char); + Move(s + 1, locs, len, char); locs[len] = 0; okay = TRUE; } @@ -580,11 +575,18 @@ Perl_set_numeric_radix(pTHX) struct lconv* lc; lc = localeconv(); - if (lc && lc->decimal_point) - /* We assume that decimal separator aka the radix - * character is always a single character. If it - * ever is a string, this needs to be rethunk. */ - PL_numeric_radix = *lc->decimal_point; + if (lc && lc->decimal_point) { + if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { + SvREFCNT_dec(PL_numeric_radix); + PL_numeric_radix = 0; + } + else { + if (PL_numeric_radix) + sv_setpv(PL_numeric_radix, lc->decimal_point); + else + PL_numeric_radix = newSVpv(lc->decimal_point, 0); + } + } else PL_numeric_radix = 0; # endif /* HAS_LOCALECONV */ @@ -663,7 +665,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * -1 = fallback to C locale failed */ -#ifdef USE_LOCALE +#if defined(USE_LOCALE) #ifdef USE_LOCALE_CTYPE char *curctype = NULL; @@ -759,18 +761,18 @@ Perl_init_i18nl10n(pTHX_ int printwarn) if (setlocale_failure) { char *p; - bool locwarn = (printwarn > 1 || + bool locwarn = (printwarn > 1 || (printwarn && (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); if (locwarn) { #ifdef LC_ALL - + PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed.\n"); #else /* !LC_ALL */ - + PerlIO_printf(Perl_error_log, "perl: warning: Setting locale failed for the categories:\n\t"); #ifdef USE_LOCALE_CTYPE @@ -806,6 +808,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) lc_all ? lc_all : "unset", lc_all ? '"' : ')'); +#if defined(USE_ENVIRON_ARRAY) { char **e; for (e = environ; *e; e++) { @@ -816,6 +819,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (int)(p - *e), *e, p + 1); } } +#else + PerlIO_printf(Perl_error_log, + "\t(possibly more locale environment variables)\n"); +#endif PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n", @@ -1070,9 +1077,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 multiline = flags & FBMrf_MULTILINE; if (bigend - big < littlelen) { - if ( SvTAIL(littlestr) + if ( SvTAIL(littlestr) && (bigend - big == littlelen - 1) - && (littlelen == 1 + && (littlelen == 1 || (*big == *little && memEQ((char *)big, (char *)little, littlelen - 1)))) return (char*)big; @@ -1164,7 +1171,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; - if (s >= big && bigend[-1] == '\n' && *s == *little + if (s >= big && bigend[-1] == '\n' && *s == *little /* Automatically of length > 2 */ && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) { @@ -1193,7 +1200,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } return b; } - + { /* Do actual FBM. */ register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; register unsigned char *oldlittle; @@ -1253,7 +1260,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit of ends of some substring of bigstr. If `last' we want the last occurence. old_posp is the way of communication between consequent calls if - the next call needs to find the . + the next call needs to find the . The initial *old_posp should be -1. Note that we take into account SvTAIL, so one can get extra @@ -1267,7 +1274,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - dTHR; register unsigned char *s, *x; register unsigned char *big; register I32 pos; @@ -1282,7 +1288,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { cant_find: - if ( BmRARE(littlestr) == '\n' + if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { little = (unsigned char *)(SvPVX(littlestr)); littleend = little + SvCUR(littlestr); @@ -1345,7 +1351,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift found = 1; } } while ( pos += PL_screamnext[pos] ); - if (last && found) + if (last && found) return (char *)(big+(*old_posp)); #endif /* POINTERRIGOR */ check_tail: @@ -1437,7 +1443,6 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len) STATIC SV * S_mess_alloc(pTHX) { - dTHR; SV *sv; XPVMG *any; @@ -1523,7 +1528,6 @@ Perl_vmess(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; if (CopLINE(PL_curcop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); @@ -1532,7 +1536,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), - line_mode ? "line" : "chunk", + line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } #ifdef USE_THREADS @@ -1547,7 +1551,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) OP * Perl_vdie(pTHX_ const char* pat, va_list *args) { - dTHR; char *message; int was_in_eval = PL_in_eval; HV *stash; @@ -1648,7 +1651,6 @@ Perl_die(pTHX_ const char* pat, ...) void Perl_vcroak(pTHX_ const char* pat, va_list *args) { - dTHR; char *message; HV *stash; GV *gv; @@ -1781,7 +1783,6 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - dTHR; SV *oldwarnhook = PL_warnhook; ENTER; SAVESPTR(PL_warnhook); @@ -1813,7 +1814,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) PerlIO_write(serr, message, msglen); #ifdef LEAKTEST - DEBUG_L(*message == '!' + DEBUG_L(*message == '!' ? (xstat(message[1]=='!' ? (message[2]=='!' ? 2 : 1) : 0) @@ -1879,7 +1880,6 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { - dTHR; char *message; HV *stash; GV *gv; @@ -1905,13 +1905,13 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; - + ENTER; save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); - + PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(sp); XPUSHs(msg); @@ -1936,7 +1936,6 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) else { if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - dTHR; SV *oldwarnhook = PL_warnhook; ENTER; SAVESPTR(PL_warnhook); @@ -1946,13 +1945,13 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; - + ENTER; save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); - + PUSHSTACKi(PERLSI_WARNHOOK); PUSHMARK(sp); XPUSHs(msg); @@ -1967,7 +1966,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) PerlIO *serr = Perl_error_log; PerlIO_write(serr, message, msglen); #ifdef LEAKTEST - DEBUG_L(*message == '!' + DEBUG_L(*message == '!' ? (xstat(message[1]=='!' ? (message[2]=='!' ? 2 : 1) : 0) @@ -2040,47 +2039,6 @@ Perl_my_setenv(pTHX_ char *nam, char *val) void Perl_my_setenv(pTHX_ char *nam,char *val) { - -#ifdef USE_WIN32_RTL_ENV - - register char *envstr; - STRLEN namlen = strlen(nam); - STRLEN vallen; - char *oldstr = environ[setenv_getix(nam)]; - - /* putenv() has totally broken semantics in both the Borland - * and Microsoft CRTLs. They either store the passed pointer in - * the environment without making a copy, or make a copy and don't - * free it. And on top of that, they dont free() old entries that - * are being replaced/deleted. This means the caller must - * free any old entries somehow, or we end up with a memory - * leak every time my_setenv() is called. One might think - * one could directly manipulate environ[], like the UNIX code - * above, but direct changes to environ are not allowed when - * calling putenv(), since the RTLs maintain an internal - * *copy* of environ[]. Bad, bad, *bad* stink. - * GSAR 97-06-07 - */ - - if (!val) { - if (!oldstr) - return; - val = ""; - vallen = 0; - } - else - vallen = strlen(val); - envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char)); - (void)sprintf(envstr,"%s=%s",nam,val); - (void)PerlEnv_putenv(envstr); - if (oldstr) - safesysfree(oldstr); -#ifdef _MSC_VER - safesysfree(envstr); /* MSVCRT leaks without this */ -#endif - -#else /* !USE_WIN32_RTL_ENV */ - register char *envstr; STRLEN len = strlen(nam) + 3; if (!val) { @@ -2091,8 +2049,6 @@ Perl_my_setenv(pTHX_ char *nam,char *val) (void)sprintf(envstr,"%s=%s",nam,val); (void)PerlEnv_putenv(envstr); Safefree(envstr); - -#endif } #endif /* WIN32 */ @@ -2371,7 +2327,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) if (doexec) { return my_syspopen(aTHX_ cmd,mode); } -#endif +#endif This = (*mode == 'w'); that = !This; if (doexec && PL_tainting) { @@ -2468,8 +2424,12 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(pp[0]); did_pipes = 0; if (n) { /* Error */ + int pid2, status; if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ return Nullfp; } @@ -2484,10 +2444,12 @@ FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) { - /* Needs work for PerlIO ! */ - /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ PERL_FLUSHALL_FOR_CHILD; - return popen(PerlIO_exportFILE(cmd, 0), mode); + /* Call system's popen() to get a FILE *, then import it. + used 0 for 2nd parameter to PerlIO_importFILE; + apparently not used + */ + return PerlIO_importFILE(popen(cmd, mode), 0); } #endif @@ -2555,8 +2517,10 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART +#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; @@ -2587,8 +2551,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(USE_PERLIO) || defined(PERL_OLD_SIGNALS) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; @@ -2670,14 +2636,14 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); UNLOCK_FDPID_MUTEX; - pid = SvIVX(*svp); + pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; SvREFCNT_dec(*svp); *svp = &PL_sv_undef; #ifdef OS2 if (pid == -1) { /* Opened by popen. */ return my_syspclose(ptr); } -#endif +#endif if ((close_failed = (PerlIO_close(ptr) == EOF))) { saved_errno = errno; #ifdef VMS @@ -2796,7 +2762,7 @@ my_syspclose(PerlIO *ptr) #else I32 Perl_my_pclose(pTHX_ PerlIO *ptr) -#endif +#endif { /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); @@ -2860,7 +2826,7 @@ Perl_cast_ulong(pTHX_ NV f) /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead of LONG_(MIN/MAX). -- Kenneth Albanowski -*/ +*/ #ifndef MY_UV_MAX # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) @@ -2968,7 +2934,6 @@ Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) continue; } else { - dTHR; if (ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ WARN_DIGIT, "Illegal binary digit '%c' ignored", *s); @@ -2979,7 +2944,6 @@ Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) register UV xuv = ruv << 1; if ((xuv >> 1) != ruv) { - dTHR; overflowed = TRUE; rnv = (NV) ruv; if (ckWARN_d(WARN_OVERFLOW)) @@ -3006,8 +2970,7 @@ Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) #if UVSIZE > 4 || (!overflowed && ruv > 0xffffffff ) #endif - ) { - dTHR; + ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Binary number > 0b11111111111111111111111111111111 non-portable"); @@ -3037,7 +3000,6 @@ Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) * 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); @@ -3049,7 +3011,6 @@ Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) register UV xuv = ruv << 3; if ((xuv >> 3) != ruv) { - dTHR; overflowed = TRUE; rnv = (NV) ruv; if (ckWARN_d(WARN_OVERFLOW)) @@ -3077,7 +3038,6 @@ Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) || (!overflowed && ruv > 0xffffffff ) #endif ) { - dTHR; if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Octal number > 037777777777 non-portable"); @@ -3092,10 +3052,20 @@ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) register char *s = start; register NV rnv = 0.0; register UV ruv = 0; - register bool seenx = FALSE; register bool overflowed = FALSE; char *hexdigit; + if (len > 2) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len > 3 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + for (; len-- && *s; s++) { hexdigit = strchr((char *) PL_hexdigit, *s); if (!hexdigit) { @@ -3105,13 +3075,7 @@ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) --len; ++s; } - else if (seenx == FALSE && *s == 'x' && ruv == 0) { - /* Disallow 0xxx0x0xxx... */ - seenx = TRUE; - continue; - } else { - dTHR; if (ckWARN(WARN_DIGIT)) Perl_warner(aTHX_ WARN_DIGIT, "Illegal hexadecimal digit '%c' ignored", *s); @@ -3122,7 +3086,6 @@ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) register UV xuv = ruv << 4; if ((xuv >> 4) != ruv) { - dTHR; overflowed = TRUE; rnv = (NV) ruv; if (ckWARN_d(WARN_OVERFLOW)) @@ -3149,8 +3112,7 @@ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) #if UVSIZE > 4 || (!overflowed && ruv > 0xffffffff ) #endif - ) { - dTHR; + ) { if (ckWARN(WARN_PORTABLE)) Perl_warner(aTHX_ WARN_PORTABLE, "Hexadecimal number > 0xffffffff non-portable"); @@ -3162,7 +3124,6 @@ Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) char* Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) { - dTHR; char *xfound = Nullch; char *xfailed = Nullch; char tmpbuf[MAXPATHLEN]; @@ -3370,7 +3331,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f } #ifndef DOSISH if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&PL_statbuf) < 0 + (PerlLIO_stat(scriptname,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))) #endif seen_dot = 1; /* Disable message. */ @@ -3450,7 +3411,7 @@ Perl_cond_signal(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond = *cp; - + if (!cond) return; t = cond->thread; @@ -3470,7 +3431,7 @@ Perl_cond_broadcast(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond, cond_next; - + for (cond = *cp; cond; cond = cond_next) { t = cond->thread; /* Insert t in the runnable queue just ahead of us */ @@ -3493,7 +3454,7 @@ Perl_cond_wait(pTHX_ perl_cond *cp) if (thr->i.next_run == thr) Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); - + New(666, cond, 1, struct perl_wait_queue); cond->thread = thr; cond->next = *cp; @@ -3509,7 +3470,7 @@ MAGIC * Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; - + SvUPGRADE(sv, SVt_PVMG); mg = mg_find(sv, 'm'); if (!mg) { @@ -3657,10 +3618,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ PL_nrs = newSVsv(t->Tnrs); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; PL_last_in_gv = Nullgv; - PL_ofslen = t->Tofslen; - PL_ofs = savepvn(t->Tofs, PL_ofslen); + PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); PL_chopset = t->Tchopset; PL_bodytarget = newSVsv(t->Tbodytarget); @@ -3681,7 +3641,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", (IV)i, t, thr)); } - } + } thr->threadsvp = AvARRAY(thr->threadsv); MUTEX_LOCK(&PL_threads_mutex); @@ -3706,10 +3666,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) /* * This hack is to force load of "huge" support from libm.a - * So it is in perl for (say) POSIX to use. + * So it is in perl for (say) POSIX to use. * Needed for SunOS with Sun's 'acc' for example. */ -NV +NV Perl_huge(void) { # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) @@ -3876,30 +3836,36 @@ Perl_get_vtbl(pTHX_ int vtbl_id) I32 Perl_my_fflush_all(pTHX) { -#ifdef FFLUSH_NULL +#if defined(FFLUSH_NULL) return PerlIO_flush(NULL); #else +# if defined(HAS__FWALK) + /* undocumented, unprototyped, but very useful BSDism */ + extern void _fwalk(int (*)(FILE *)); + _fwalk(&fflush); + return 0; +# else long open_max = -1; -# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) -# ifdef PERL_FFLUSH_ALL_FOPEN_MAX +# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) +# ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; -# else -# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) +# else +# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); -# else -# ifdef FOPEN_MAX - open_max = FOPEN_MAX; # else -# ifdef OPEN_MAX - open_max = OPEN_MAX; +# ifdef FOPEN_MAX + open_max = FOPEN_MAX; # else -# ifdef _NFILE +# ifdef OPEN_MAX + open_max = OPEN_MAX; +# else +# ifdef _NFILE open_max = _NFILE; +# endif # endif # endif # endif -# endif -# endif +# endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) @@ -3909,9 +3875,10 @@ Perl_my_fflush_all(pTHX) PerlIO_flush(&STDIO_STREAM_ARRAY[i]); return 0; } -# endif +# endif SETERRNO(EBADF,RMS$_IFI); return EOF; +# endif #endif } @@ -3967,7 +3934,15 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) name = SvPVX(sv); } - if (name && *name) { + if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { + if (name && *name) + Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput", + name, + (op == OP_phoney_INPUT_ONLY ? "in" : "out")); + else + Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput", + (op == OP_phoney_INPUT_ONLY ? "in" : "out")); + } else if (name && *name) { Perl_warner(aTHX_ warn_type, "%s%s on %s %s %s", func, pars, vile, type, name); if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) @@ -3984,3 +3959,43 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) func, pars); } } + +#ifdef EBCDIC +/* in ASCII order, not that it matters */ +static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; + +int +Perl_ebcdic_control(pTHX_ int ch) +{ + if (ch > 'a') { + char *ctlp; + + if (islower(ch)) + ch = toupper(ch); + + if ((ctlp = strchr(controllablechars, ch)) == 0) { + Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); + } + + if (ctlp == controllablechars) + return('\177'); /* DEL */ + else + return((unsigned char)(ctlp - controllablechars - 1)); + } else { /* Want uncontrol */ + if (ch == '\177' || ch == -1) + return('?'); + else if (ch == '\157') + return('\177'); + else if (ch == '\174') + return('\000'); + else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ + return('\036'); + else if (ch == '\155') + return('\037'); + else if (0 < ch && ch < (sizeof(controllablechars) - 1)) + return(controllablechars[ch+1]); + else + Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); + } +} +#endif