X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=720bcf063173bc605c9ce77b7675218443bb89f7;hb=374f98998144a5e58919ddd781cb75f885e750f6;hp=1261b98331d030c82cf666d381f960491fb6ca94;hpb=245f541b6f35ec487dff355c77302d41b2c043a6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 1261b98..720bcf0 100644 --- a/util.c +++ b/util.c @@ -575,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 */ } @@ -658,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; @@ -801,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++) { @@ -811,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", @@ -2027,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) { @@ -2078,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 */ @@ -2340,6 +2309,131 @@ 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 */ + GV* tmpgv; + int fd; +#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 + 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 * @@ -2548,8 +2642,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; @@ -2580,8 +2676,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; @@ -2663,7 +2761,7 @@ 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 @@ -3645,9 +3743,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_ofs_sv = SvREFCNT_inc(PL_ofs_sv); + 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); @@ -3942,11 +4040,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; } @@ -3980,9 +4079,342 @@ 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 +} +