X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=c5a3af3fc597a83803a1d24f4cac2cc393539289;hb=cb359b415c42e7a6c1192036d2ee416133c9daa1;hp=1261b98331d030c82cf666d381f960491fb6ca94;hpb=0e06870bf080a38cda51c06c6612359afc2334e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 1261b98..c5a3af3 100644 --- a/util.c +++ b/util.c @@ -575,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 */ @@ -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); @@ -3986,3 +4084,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