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 */
* -1 = fallback to C locale failed
*/
-#ifdef USE_LOCALE
+#if defined(USE_LOCALE)
#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
lc_all ? lc_all : "unset",
lc_all ? '"' : ')');
+#if defined(USE_ENVIRON_ARRAY)
{
char **e;
for (e = environ; *e; e++) {
(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",
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) {
(void)sprintf(envstr,"%s=%s",nam,val);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
-
-#endif
}
#endif /* WIN32 */
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 *
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