X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ecaf18ba026d59067ac15344724117defc493850;hb=7b57b0ead8ab6b3f08be8b4ded2364d260db25a1;hp=34cdaafe8a29e1b92134edd45d6039b2b4ee0c96;hpb=0fe4d7f53271875ddab9f5e0b0a212f9b7878acb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 34cdaaf..ecaf18b 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,13 +575,20 @@ 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_sv); + PL_numeric_radix_sv = Nullsv; + } + else { + if (PL_numeric_radix_sv) + sv_setpv(PL_numeric_radix_sv, lc->decimal_point); + else + PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); + } + } else - PL_numeric_radix = 0; + PL_numeric_radix_sv = Nullsv; # endif /* HAS_LOCALECONV */ #endif /* USE_LOCALE_NUMERIC */ } @@ -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", @@ -1026,7 +1033,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s--, i++; } } - sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ + sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ @@ -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) @@ -1981,7 +1980,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) #ifdef USE_ENVIRON_ARRAY /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#if !defined(WIN32) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -2023,95 +2022,23 @@ Perl_my_setenv(pTHX_ char *nam, char *val) (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ #else /* PERL_USE_SAFE_PUTENV */ +# if defined(__CYGWIN__) + setenv(nam, val, 1); +# else char *new_env; new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char)); (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */ (void)putenv(new_env); +# endif /* __CYGWIN__ */ #endif /* PERL_USE_SAFE_PUTENV */ } -#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. - */ -static char ***Perl_main_environ; - -EXTERN_C void -Perl_my_setenv_init(char ***penviron) -{ - Perl_main_environ = penviron; -} - -void -Perl_my_setenv(pTHX_ char *nam, char *val) -{ - /* You can not directly manipulate the environ[] array because - * the routines do some additional work that syncs the Cygwin - * environment with the Windows environment. - */ - char *oldstr = environ[setenv_getix(nam)]; - - if (!val) { - if (!oldstr) - return; - unsetenv(nam); - safesysfree(oldstr); - return; - } - setenv(nam, val, 1); - environ = *Perl_main_environ; /* environ realloc can occur in setenv */ - if(oldstr && environ[setenv_getix(nam)] != oldstr) - safesysfree(oldstr); -} -#else /* if WIN32 */ +#else /* WIN32 */ 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) { @@ -2122,12 +2049,9 @@ Perl_my_setenv(pTHX_ char *nam,char *val) (void)sprintf(envstr,"%s=%s",nam,val); (void)PerlEnv_putenv(envstr); Safefree(envstr); - -#endif } #endif /* WIN32 */ -#endif I32 Perl_setenv_getix(pTHX_ char *nam) @@ -2385,6 +2309,133 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif +PerlIO * +Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) +{ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) + int p[2]; + register I32 This, that; + register Pid_t pid; + SV *sv; + I32 did_pipes = 0; + int pp[2]; + + PERL_FLUSHALL_FOR_CHILD; + This = (*mode == 'w'); + that = !This; + if (PL_tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); + } + if (PerlProc_pipe(p) < 0) + return Nullfp; + /* Try for another pipe pair for error return */ + if (PerlProc_pipe(pp) >= 0) + did_pipes = 1; + while ((pid = vfork()) < 0) { + if (errno != EAGAIN) { + PerlLIO_close(p[This]); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } + return Nullfp; + } + sleep(5); + } + if (pid == 0) { + /* Child */ +#undef THIS +#undef THAT +#define THIS that +#define THAT This + /* Close parent's end of _the_ pipe */ + PerlLIO_close(p[THAT]); + /* Close parent's end of error status pipe (if any) */ + if (did_pipes) { + PerlLIO_close(pp[0]); +#if defined(HAS_FCNTL) && defined(F_SETFD) + /* Close error pipe automatically if exec works */ + fcntl(pp[1], F_SETFD, FD_CLOEXEC); +#endif + } + /* Now dup our end of _the_ pipe to right position */ + if (p[THIS] != (*mode == 'r')) { + PerlLIO_dup2(p[THIS], *mode == 'r'); + PerlLIO_close(p[THIS]); + } +#if !defined(HAS_FCNTL) || !defined(F_SETFD) + /* No automatic close - do it by hand */ +# ifndef NOFILE +# define NOFILE 20 +# endif + { + int fd; + + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { + if (fd != pp[1]) + PerlLIO_close(fd); + } + } +#endif + do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); + PerlProc__exit(1); +#undef THIS +#undef THAT + } + /* Parent */ + do_execfree(); /* free any memory malloced by child on vfork */ + /* Close child's end of pipe */ + PerlLIO_close(p[that]); + if (did_pipes) + PerlLIO_close(pp[1]); + /* Keep the lower of the two fd numbers */ + if (p[that] < p[This]) { + PerlLIO_dup2(p[This], p[that]); + PerlLIO_close(p[This]); + p[This] = p[that]; + } + LOCK_FDPID_MUTEX; + sv = *av_fetch(PL_fdpid,p[This],TRUE); + UNLOCK_FDPID_MUTEX; + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = pid; + PL_forkprocess = pid; + /* If we managed to get status pipe check for exec fail */ + if (did_pipes && pid > 0) { + int errkid; + int n = 0, n1; + + while (n < sizeof(int)) { + n1 = PerlLIO_read(pp[0], + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + 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; + } + } + if (did_pipes) + PerlLIO_close(pp[0]); + return PerlIO_fdopen(p[This], mode); +#else + Perl_croak(aTHX_ "List form of piped open not implemented"); + return (PerlIO *) NULL; +#endif +} + /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) PerlIO * @@ -2403,7 +2454,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) { @@ -2453,11 +2504,16 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #ifndef NOFILE #define NOFILE 20 #endif - for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) - if (fd != pp[1]) - PerlLIO_close(fd); + { + int fd; + + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) + if (fd != pp[1]) + PerlLIO_close(fd); + } #endif - do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */ + /* may or may not use the shell */ + do_exec3(cmd, pp[1], did_pipes); PerlProc__exit(1); } #endif /* defined OS2 */ @@ -2500,8 +2556,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; } @@ -2516,10 +2576,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 @@ -2587,8 +2649,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; @@ -2619,8 +2683,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; @@ -2691,7 +2757,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid; Pid_t pid2; bool close_failed; - int saved_errno; + int saved_errno = 0; #ifdef VMS int saved_vaxc_errno; #endif @@ -2702,14 +2768,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 @@ -2747,13 +2813,14 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { + if (!pid) + return -1; +#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) + { SV *sv; SV** svp; char spid[TYPE_CHARS(int)]; - if (!pid) - return -1; -#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); @@ -2775,6 +2842,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } + } } #endif #ifdef HAS_WAITPID @@ -2828,7 +2896,7 @@ my_syspclose(PerlIO *ptr) #else I32 Perl_my_pclose(pTHX_ PerlIO *ptr) -#endif +#endif { /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); @@ -2864,80 +2932,74 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi U32 Perl_cast_ulong(pTHX_ NV f) { - long along; - + if (f < 0.0) + return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; + if (f < U32_MAX_P1) { #if CASTFLAGS & 2 -# define BIGDOUBLE 2147483648.0 - if (f >= BIGDOUBLE) - return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; -#endif - if (f >= 0.0) - return (unsigned long)f; - along = (long)f; - return (unsigned long)along; -} -# undef BIGDOUBLE - -/* Unfortunately, on some systems the cast_uv() function doesn't - work with the system-supplied definition of ULONG_MAX. The - comparison (f >= ULONG_MAX) always comes out true. It must be a - problem with the compiler constant folding. - - In any case, this workaround should be fine on any two's complement - system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your - ccflags. - --Andy Dougherty -*/ - -/* 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) + if (f < U32_MAX_P1_HALF) + return (U32) f; + f -= U32_MAX_P1_HALF; + return ((U32) f) | (1 + U32_MAX >> 1); +#else + return (U32) f; #endif + } + return f > 0 ? U32_MAX : 0 /* NaN */; +} I32 Perl_cast_i32(pTHX_ NV f) { - if (f >= I32_MAX) - return (I32) I32_MAX; - if (f <= I32_MIN) - return (I32) I32_MIN; - return (I32) f; + if (f < I32_MAX_P1) + return f < I32_MIN ? I32_MIN : (I32) f; + if (f < U32_MAX_P1) { +#if CASTFLAGS & 2 + if (f < U32_MAX_P1_HALF) + return (I32)(U32) f; + f -= U32_MAX_P1_HALF; + return (I32)(((U32) f) | (1 + U32_MAX >> 1)); +#else + return (I32)(U32) f; +#endif + } + return f > 0 ? (I32)U32_MAX : 0 /* NaN */; } IV Perl_cast_iv(pTHX_ NV f) { - if (f >= IV_MAX) { - UV uv; - - if (f >= (NV)UV_MAX) - return (IV) UV_MAX; - uv = (UV) f; - return (IV)uv; - } - if (f <= IV_MIN) - return (IV) IV_MIN; - return (IV) f; + if (f < IV_MAX_P1) + return f < IV_MIN ? IV_MIN : (IV) f; + if (f < UV_MAX_P1) { +#if CASTFLAGS & 2 + /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */ + if (f < UV_MAX_P1_HALF) + return (IV)(UV) f; + f -= UV_MAX_P1_HALF; + return (IV)(((UV) f) | (1 + UV_MAX >> 1)); +#else + return (IV)(UV) f; +#endif + } + return f > 0 ? (IV)UV_MAX : 0 /* NaN */; } UV Perl_cast_uv(pTHX_ NV f) { - if (f >= MY_UV_MAX) - return (UV) MY_UV_MAX; - if (f < 0) { - IV iv; - - if (f < IV_MIN) - return (UV)IV_MIN; - iv = (IV) f; - return (UV) iv; - } + if (f < 0.0) + return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; + if (f < UV_MAX_P1) { +#if CASTFLAGS & 2 + if (f < UV_MAX_P1_HALF) + return (UV) f; + f -= UV_MAX_P1_HALF; + return ((UV) f) | (1 + UV_MAX >> 1); +#else return (UV) f; +#endif + } + return f > 0 ? UV_MAX : 0 /* NaN */; } #ifndef HAS_RENAME @@ -3000,7 +3062,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); @@ -3011,7 +3072,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)) @@ -3038,8 +3098,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"); @@ -3069,7 +3128,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); @@ -3081,7 +3139,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)) @@ -3109,7 +3166,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"); @@ -3124,10 +3180,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) { @@ -3137,13 +3203,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); @@ -3154,7 +3214,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)) @@ -3181,8 +3240,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"); @@ -3194,7 +3252,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]; @@ -3402,7 +3459,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. */ @@ -3435,11 +3492,11 @@ Perl_get_context(void) Perl_croak_nocontext("panic: pthread_getspecific"); return (void*)t; # else -# ifdef I_MACH_CTHREADS +# ifdef I_MACH_CTHREADS return (void*)cthread_data(cthread_self()); -# else - return (void*)pthread_getspecific(PL_thr_key); -# endif +# else + return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); +# endif # endif #else return (void*)NULL; @@ -3482,7 +3539,7 @@ Perl_cond_signal(pTHX_ perl_cond *cp) { perl_os_thread t; perl_cond cond = *cp; - + if (!cond) return; t = cond->thread; @@ -3502,7 +3559,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 */ @@ -3525,7 +3582,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; @@ -3541,9 +3598,9 @@ MAGIC * Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; - + SvUPGRADE(sv, SVt_PVMG); - mg = mg_find(sv, 'm'); + mg = mg_find(sv, PERL_MAGIC_mutex); if (!mg) { condpair_t *cp; @@ -3553,7 +3610,7 @@ Perl_condpair_magic(pTHX_ SV *sv) COND_INIT(&cp->cond); cp->owner = 0; LOCK_CRED_MUTEX; /* XXX need separate mutex? */ - mg = mg_find(sv, 'm'); + mg = mg_find(sv, PERL_MAGIC_mutex); if (mg) { /* someone else beat us to initialising it */ UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ @@ -3563,7 +3620,7 @@ Perl_condpair_magic(pTHX_ SV *sv) Safefree(cp); } else { - sv_magic(sv, Nullsv, 'm', 0, 0); + sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0); mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); @@ -3689,10 +3746,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); @@ -3708,12 +3764,12 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) if (*svp && *svp != &PL_sv_undef) { SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); - sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); + sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1); DEBUG_S(PerlIO_printf(Perl_debug_log, "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", (IV)i, t, thr)); } - } + } thr->threadsvp = AvARRAY(thr->threadsv); MUTEX_LOCK(&PL_threads_mutex); @@ -3738,10 +3794,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) @@ -3908,30 +3964,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 +# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) long open_max = -1; -# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) -# ifdef PERL_FFLUSH_ALL_FOPEN_MAX +# 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 +# else +# ifdef FOPEN_MAX open_max = FOPEN_MAX; -# else -# ifdef OPEN_MAX +# else +# ifdef OPEN_MAX open_max = OPEN_MAX; -# else -# ifdef _NFILE +# else +# ifdef _NFILE open_max = _NFILE; +# endif +# endif +# endif # endif # endif -# endif -# endif -# endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) @@ -3941,9 +4003,10 @@ Perl_my_fflush_all(pTHX) PerlIO_flush(&STDIO_STREAM_ARRAY[i]); return 0; } -# endif +# endif SETERRNO(EBADF,RMS$_IFI); return EOF; +# endif #endif } @@ -3952,24 +4015,183 @@ Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; #ifdef USE_LOCALE_NUMERIC - if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { + if (PL_numeric_local && IN_LOCALE) { NV y; - Perl_atof2(s, x); + Perl_atof2(aTHX_ s, &x); SET_NUMERIC_STANDARD(); - Perl_atof2(s, y); + Perl_atof2(aTHX_ s, &y); SET_NUMERIC_LOCAL(); if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) return y; } else - Perl_atof2(s, x); + Perl_atof2(aTHX_ s, &x); #else - Perl_atof2(s, x); + Perl_atof2(aTHX_ s, &x); #endif return x; } +NV +S_mulexp10(NV value, I32 exponent) +{ + NV result = 1.0; + NV power = 10.0; + bool negative = 0; + I32 bit; + + if (exponent == 0) + return value; + else if (exponent < 0) { + negative = 1; + exponent = -exponent; + } + for (bit = 1; exponent; bit <<= 1) { + if (exponent & bit) { + exponent ^= bit; + result *= power; + } + power *= power; + } + return negative ? value / result : value * result; +} + +char* +Perl_my_atof2(pTHX_ const char* orig, NV* value) +{ + NV result = 0.0; + bool negative = 0; + char* s = (char*)orig; + char* point = "."; /* locale-dependent decimal point equivalent */ + STRLEN pointlen = 1; + bool seendigit = 0; + I32 expextra = 0; + I32 exponent = 0; + I32 i; +/* this is arbitrary */ +#define PARTLIM 6 +/* we want the largest integers we can usefully use */ +#if defined(HAS_QUAD) && defined(USE_64_BIT_INT) +# define PARTSIZE ((int)TYPE_DIGITS(U64)-1) + U64 part[PARTLIM]; +#else +# define PARTSIZE ((int)TYPE_DIGITS(U32)-1) + U32 part[PARTLIM]; +#endif + I32 ipart = 0; /* index into part[] */ + I32 offcount; /* number of digits in least significant part */ + +#ifdef USE_LOCALE_NUMERIC + if (PL_numeric_radix_sv && IN_LOCALE) + point = SvPV(PL_numeric_radix_sv, pointlen); +#endif + + /* sign */ + switch (*s) { + case '-': + negative = 1; + /* fall through */ + case '+': + ++s; + } + + part[0] = offcount = 0; + if (isDIGIT(*s)) { + seendigit = 1; /* get this over with */ + + /* skip leading zeros */ + while (*s == '0') + ++s; + } + + /* integer digits */ + while (isDIGIT(*s)) { + if (++offcount > PARTSIZE) { + if (++ipart < PARTLIM) { + part[ipart] = 0; + offcount = 1; /* ++0 */ + } + else { + /* limits of precision reached */ + --ipart; + --offcount; + if (*s >= '5') + ++part[ipart]; + while (isDIGIT(*s)) { + ++expextra; + ++s; + } + /* warn of loss of precision? */ + break; + } + } + part[ipart] = part[ipart] * 10 + (*s++ - '0'); + } + + /* decimal point */ + if (memEQ(s, point, pointlen)) { + s += pointlen; + if (isDIGIT(*s)) + seendigit = 1; /* get this over with */ + + /* decimal digits */ + while (isDIGIT(*s)) { + if (++offcount > PARTSIZE) { + if (++ipart < PARTLIM) { + part[ipart] = 0; + offcount = 1; /* ++0 */ + } + else { + /* limits of precision reached */ + --ipart; + --offcount; + if (*s >= '5') + ++part[ipart]; + while (isDIGIT(*s)) + ++s; + /* warn of loss of precision? */ + break; + } + } + --expextra; + part[ipart] = part[ipart] * 10 + (*s++ - '0'); + } + } + + /* combine components of mantissa */ + for (i = 0; i <= ipart; ++i) + result += S_mulexp10((NV)part[ipart - i], + i ? offcount + (i - 1) * PARTSIZE : 0); + + if (seendigit && (*s == 'e' || *s == 'E')) { + bool expnegative = 0; + + ++s; + switch (*s) { + case '-': + expnegative = 1; + /* fall through */ + case '+': + ++s; + } + while (isDIGIT(*s)) + exponent = exponent * 10 + (*s++ - '0'); + if (expnegative) + exponent = -exponent; + } + + /* now apply the exponent */ + exponent += expextra; + result = S_mulexp10(result, exponent); + + /* now apply the sign */ + if (negative) + result = -result; + *value = result; + return s; +} + void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) { @@ -3980,11 +4202,12 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]; char *pars = OP_IS_FILETEST(op) ? "" : "()"; - char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? + char *type = OP_IS_SOCKET(op) || + (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; char *name = NULL; - if (io && IoTYPE(io) == IoTYPE_CLOSED) { + if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { vile = "closed"; warn_type = WARN_CLOSED; } @@ -3999,7 +4222,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)) @@ -4010,9 +4241,655 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) else { Perl_warner(aTHX_ warn_type, "%s%s on %s %s", func, pars, vile, type); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) Perl_warner(aTHX_ warn_type, "\t(Are you trying to call %s%s on dirhandle?)\n", 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 + +/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) + * fields for which we don't have Configure support yet: + * char *tm_zone; -- abbreviation of timezone name + * long tm_gmtoff; -- offset from GMT in seconds + * To workaround core dumps from the uninitialised tm_zone we get the + * system to give us a reasonable struct to copy. This fix means that + * strftime uses the tm_zone and tm_gmtoff values returned by + * localtime(time()). That should give the desired result most of the + * time. But probably not always! + * + * This is a temporary workaround to be removed once Configure + * support is added and NETaa14816 is considered in full. + * It does not address tzname aspects of NETaa14816. + */ +#ifdef HAS_GNULIBC +# ifndef STRUCT_TM_HASZONE +# define STRUCT_TM_HASZONE +# endif +#endif + +void +Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ +{ +#ifdef STRUCT_TM_HASZONE + Time_t now; + (void)time(&now); + Copy(localtime(&now), ptm, 1, struct tm); +#endif +} + +/* + * mini_mktime - normalise struct tm values without the localtime() + * semantics (and overhead) of mktime(). + */ +void +Perl_mini_mktime(pTHX_ struct tm *ptm) +{ + int yearday; + int secs; + int month, mday, year, jday; + int odd_cent, odd_year; + +#define DAYS_PER_YEAR 365 +#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) +#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) +#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) +#define SECS_PER_HOUR (60*60) +#define SECS_PER_DAY (24*SECS_PER_HOUR) +/* parentheses deliberately absent on these two, otherwise they don't work */ +#define MONTH_TO_DAYS 153/5 +#define DAYS_TO_MONTH 5/153 +/* offset to bias by March (month 4) 1st between month/mday & year finding */ +#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) +/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ +#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ + +/* + * Year/day algorithm notes: + * + * With a suitable offset for numeric value of the month, one can find + * an offset into the year by considering months to have 30.6 (153/5) days, + * using integer arithmetic (i.e., with truncation). To avoid too much + * messing about with leap days, we consider January and February to be + * the 13th and 14th month of the previous year. After that transformation, + * we need the month index we use to be high by 1 from 'normal human' usage, + * so the month index values we use run from 4 through 15. + * + * Given that, and the rules for the Gregorian calendar (leap years are those + * divisible by 4 unless also divisible by 100, when they must be divisible + * by 400 instead), we can simply calculate the number of days since some + * arbitrary 'beginning of time' by futzing with the (adjusted) year number, + * the days we derive from our month index, and adding in the day of the + * month. The value used here is not adjusted for the actual origin which + * it normally would use (1 January A.D. 1), since we're not exposing it. + * We're only building the value so we can turn around and get the + * normalised values for the year, month, day-of-month, and day-of-year. + * + * For going backward, we need to bias the value we're using so that we find + * the right year value. (Basically, we don't want the contribution of + * March 1st to the number to apply while deriving the year). Having done + * that, we 'count up' the contribution to the year number by accounting for + * full quadracenturies (400-year periods) with their extra leap days, plus + * the contribution from full centuries (to avoid counting in the lost leap + * days), plus the contribution from full quad-years (to count in the normal + * leap days), plus the leftover contribution from any non-leap years. + * At this point, if we were working with an actual leap day, we'll have 0 + * days left over. This is also true for March 1st, however. So, we have + * to special-case that result, and (earlier) keep track of the 'odd' + * century and year contributions. If we got 4 extra centuries in a qcent, + * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. + * Otherwise, we add back in the earlier bias we removed (the 123 from + * figuring in March 1st), find the month index (integer division by 30.6), + * and the remainder is the day-of-month. We then have to convert back to + * 'real' months (including fixing January and February from being 14/15 in + * the previous year to being in the proper year). After that, to get + * tm_yday, we work with the normalised year and get a new yearday value for + * January 1st, which we subtract from the yearday value we had earlier, + * representing the date we've re-built. This is done from January 1 + * because tm_yday is 0-origin. + * + * Since POSIX time routines are only guaranteed to work for times since the + * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm + * applies Gregorian calendar rules even to dates before the 16th century + * doesn't bother me. Besides, you'd need cultural context for a given + * date to know whether it was Julian or Gregorian calendar, and that's + * outside the scope for this routine. Since we convert back based on the + * same rules we used to build the yearday, you'll only get strange results + * for input which needed normalising, or for the 'odd' century years which + * were leap years in the Julian calander but not in the Gregorian one. + * I can live with that. + * + * This algorithm also fails to handle years before A.D. 1 gracefully, but + * that's still outside the scope for POSIX time manipulation, so I don't + * care. + */ + + year = 1900 + ptm->tm_year; + month = ptm->tm_mon; + mday = ptm->tm_mday; + /* allow given yday with no month & mday to dominate the result */ + if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { + month = 0; + mday = 0; + jday = 1 + ptm->tm_yday; + } + else { + jday = 0; + } + if (month >= 2) + month+=2; + else + month+=14, year--; + yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; + yearday += month*MONTH_TO_DAYS + mday + jday; + /* + * Note that we don't know when leap-seconds were or will be, + * so we have to trust the user if we get something which looks + * like a sensible leap-second. Wild values for seconds will + * be rationalised, however. + */ + if ((unsigned) ptm->tm_sec <= 60) { + secs = 0; + } + else { + secs = ptm->tm_sec; + ptm->tm_sec = 0; + } + secs += 60 * ptm->tm_min; + secs += SECS_PER_HOUR * ptm->tm_hour; + if (secs < 0) { + if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { + /* got negative remainder, but need positive time */ + /* back off an extra day to compensate */ + yearday += (secs/SECS_PER_DAY)-1; + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); + } + else { + yearday += (secs/SECS_PER_DAY); + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); + } + } + else if (secs >= SECS_PER_DAY) { + yearday += (secs/SECS_PER_DAY); + secs %= SECS_PER_DAY; + } + ptm->tm_hour = secs/SECS_PER_HOUR; + secs %= SECS_PER_HOUR; + ptm->tm_min = secs/60; + secs %= 60; + ptm->tm_sec += secs; + /* done with time of day effects */ + /* + * The algorithm for yearday has (so far) left it high by 428. + * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to + * bias it by 123 while trying to figure out what year it + * really represents. Even with this tweak, the reverse + * translation fails for years before A.D. 0001. + * It would still fail for Feb 29, but we catch that one below. + */ + jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ + yearday -= YEAR_ADJUST; + year = (yearday / DAYS_PER_QCENT) * 400; + yearday %= DAYS_PER_QCENT; + odd_cent = yearday / DAYS_PER_CENT; + year += odd_cent * 100; + yearday %= DAYS_PER_CENT; + year += (yearday / DAYS_PER_QYEAR) * 4; + yearday %= DAYS_PER_QYEAR; + odd_year = yearday / DAYS_PER_YEAR; + year += odd_year; + yearday %= DAYS_PER_YEAR; + if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ + month = 1; + yearday = 29; + } + else { + yearday += YEAR_ADJUST; /* recover March 1st crock */ + month = yearday*DAYS_TO_MONTH; + yearday -= month*MONTH_TO_DAYS; + /* recover other leap-year adjustment */ + if (month > 13) { + month-=14; + year++; + } + else { + month-=2; + } + } + ptm->tm_year = year - 1900; + if (yearday) { + ptm->tm_mday = yearday; + ptm->tm_mon = month; + } + else { + ptm->tm_mday = 31; + ptm->tm_mon = month - 1; + } + /* re-build yearday based on Jan 1 to get tm_yday */ + year--; + yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; + yearday += 14*MONTH_TO_DAYS + 1; + ptm->tm_yday = jday - yearday; + /* fix tm_wday if not overridden by caller */ + if ((unsigned)ptm->tm_wday > 6) + ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; +} + +char * +Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) +{ +#ifdef HAS_STRFTIME + char *buf; + int buflen; + struct tm mytm; + int len; + + init_tm(&mytm); /* XXX workaround - see init_tm() above */ + mytm.tm_sec = sec; + mytm.tm_min = min; + mytm.tm_hour = hour; + mytm.tm_mday = mday; + mytm.tm_mon = mon; + mytm.tm_year = year; + mytm.tm_wday = wday; + mytm.tm_yday = yday; + mytm.tm_isdst = isdst; + mini_mktime(&mytm); + buflen = 64; + New(0, buf, buflen, char); + len = strftime(buf, buflen, fmt, &mytm); + /* + ** The following is needed to handle to the situation where + ** tmpbuf overflows. Basically we want to allocate a buffer + ** and try repeatedly. The reason why it is so complicated + ** is that getting a return value of 0 from strftime can indicate + ** one of the following: + ** 1. buffer overflowed, + ** 2. illegal conversion specifier, or + ** 3. the format string specifies nothing to be returned(not + ** an error). This could be because format is an empty string + ** or it specifies %p that yields an empty string in some locale. + ** If there is a better way to make it portable, go ahead by + ** all means. + */ + if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) + return buf; + else { + /* Possibly buf overflowed - try again with a bigger buf */ + int fmtlen = strlen(fmt); + int bufsize = fmtlen + buflen; + + New(0, buf, bufsize, char); + while (buf) { + buflen = strftime(buf, bufsize, fmt, &mytm); + if (buflen > 0 && buflen < bufsize) + break; + /* heuristic to prevent out-of-memory errors */ + if (bufsize > 100*fmtlen) { + Safefree(buf); + buf = NULL; + break; + } + bufsize *= 2; + Renew(buf, bufsize, char); + } + return buf; + } +#else + Perl_croak(aTHX_ "panic: no strftime"); +#endif +} + + +#define SV_CWD_RETURN_UNDEF \ +sv_setsv(sv, &PL_sv_undef); \ +return FALSE + +#define SV_CWD_ISDOT(dp) \ + (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) + +/* +=for apidoc sv_getcwd + +Fill the sv with current working directory + +=cut +*/ + +/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. + * rewritten again by dougm, optimized for use with xs TARG, and to prefer + * getcwd(3) if available + * Comments from the orignal: + * This is a faster version of getcwd. It's also more dangerous + * because you might chdir out of a directory that you can't chdir + * back into. */ + +/* XXX: this needs more porting #ifndef HAS_GETCWD */ +int +Perl_sv_getcwd(pTHX_ register SV *sv) +{ +#ifndef PERL_MICRO + +#ifndef HAS_GETCWD + struct stat statbuf; + int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; + int namelen, pathlen=0; + DIR *dir; + Direntry_t *dp; +#endif + + (void)SvUPGRADE(sv, SVt_PV); + +#ifdef HAS_GETCWD + + SvGROW(sv, 128); + while ((getcwd(SvPVX(sv), SvLEN(sv)-1) == NULL) && errno == ERANGE) { + SvGROW(sv, SvLEN(sv) + 128); + } + SvCUR_set(sv, strlen(SvPVX(sv))); + SvPOK_only(sv); + +#else + + if (PerlLIO_lstat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + orig_cdev = statbuf.st_dev; + orig_cino = statbuf.st_ino; + cdev = orig_cdev; + cino = orig_cino; + + for (;;) { + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } + + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } + + if (!dp) { + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } + + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); + +#ifdef VOID_CLOSEDIR + PerlDir_close(dir); +#else + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } +#endif + } + + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); + + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (cdev != orig_cdev || cino != orig_cino) { + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); + } +#endif + + return TRUE; +#else + return FALSE; +#endif +} + +/* +=for apidoc sv_realpath + +Wrap or emulate realpath(3). + +=cut + */ +int +Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) +{ +#ifndef PERL_MICRO + char name[MAXPATHLEN] = { 0 }, *s; + STRLEN pathlen, namelen; + +#ifdef HAS_REALPATH + /* Be paranoid about the use of realpath(), + * it is an infamous source of buffer overruns. */ + + /* Is the source buffer too long? + * Don't use strlen() to avoid running off the end. */ + s = memchr(path, '\0', MAXPATHLEN); + pathlen = s ? s - path : MAXPATHLEN; + if (pathlen == MAXPATHLEN) { + Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", + path, s ? '=' : '>', MAXPATHLEN); + SV_CWD_RETURN_UNDEF; + } + + /* Here goes nothing. */ + if (realpath(path, name) == NULL) { + Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %s", + path, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } + + /* Is the destination buffer too long? + * Don't use strlen() to avoid running off the end. */ + s = memchr(name, '\0', MAXPATHLEN); + namelen = s ? s - name : MAXPATHLEN; + if (namelen == MAXPATHLEN) { + Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", + path, s ? '=' : '>', MAXPATHLEN); + SV_CWD_RETURN_UNDEF; + } + + /* The coast is clear? */ + sv_setpvn(sv, name, namelen); + SvPOK_only(sv); + + return TRUE; +#else + DIR *parent; + Direntry_t *dp; + char dotdots[MAXPATHLEN] = { 0 }; + struct stat cst, pst, tst; + + if (PerlLIO_stat(path, &cst) < 0) { + Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s", + path, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } + + (void)SvUPGRADE(sv, SVt_PV); + + if (!len) { + len = strlen(path); + } + Copy(path, dotdots, len, char); + + for (;;) { + strcat(dotdots, "/.."); + StructCopy(&cst, &pst, struct stat); + + if (PerlLIO_stat(dotdots, &cst) < 0) { + Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s", + dotdots, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } + + if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) { + /* We've reached the root: previous is same as current */ + break; + } else { + STRLEN dotdotslen = strlen(dotdots); + + /* Scan through the dir looking for name of previous */ + if (!(parent = PerlDir_open(dotdots))) { + Perl_warn(aTHX_ "sv_realpath: opendir(\"%s\"): %s", + dotdots, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } + + SETERRNO(0,SS$_NORMAL); /* for readdir() */ + while ((dp = PerlDir_read(parent)) != NULL) { + if (SV_CWD_ISDOT(dp)) { + continue; + } + + Copy(dotdots, name, dotdotslen, char); + name[dotdotslen] = '/'; +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + Copy(dp->d_name, name + dotdotslen + 1, namelen, char); + name[dotdotslen + 1 + namelen] = 0; + + if (PerlLIO_lstat(name, &tst) < 0) { + PerlDir_close(parent); + Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s", + name, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } + + if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino) + break; + + SETERRNO(0,SS$_NORMAL); /* for readdir() */ + } + + if (!dp && errno) { + Perl_warn(aTHX_ "sv_realpath: readdir(\"%s\"): %s", + dotdots, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } + + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); + +#ifdef VOID_CLOSEDIR + PerlDir_close(parent); +#else + if (PerlDir_close(parent) < 0) { + Perl_warn(aTHX_ "sv_realpath: closedir(\"%s\"): %s", + dotdots, Strerror(errno)); + SV_CWD_RETURN_UNDEF; + } +#endif + } + } + + SvCUR_set(sv, pathlen); + SvPOK_only(sv); + + return TRUE; +#endif +#else + return FALSE; +#endif +}