#ifdef I_UNISTD
#include <unistd.h>
#endif
-#ifdef MACOS_TRADITIONAL
-#undef fdopen
-#endif
#include <fcntl.h>
#ifdef HAS_TZNAME
#else
# ifndef HAS_MKFIFO
-# if defined(OS2) || defined(MACOS_TRADITIONAL)
+# if defined(OS2)
# define mkfifo(a,b) not_here("mkfifo")
# else /* !( defined OS2 ) */
# ifndef mkfifo
# endif
# endif /* !HAS_MKFIFO */
-# ifdef MACOS_TRADITIONAL
-# define ttyname(a) (char*)not_here("ttyname")
-# define tzset() not_here("tzset")
-# else
-# ifdef I_GRP
-# include <grp.h>
-# endif
-# include <sys/times.h>
-# ifdef HAS_UNAME
-# include <sys/utsname.h>
-# endif
-# include <sys/wait.h>
+# ifdef I_GRP
+# include <grp.h>
+# endif
+# include <sys/times.h>
+# ifdef HAS_UNAME
+# include <sys/utsname.h>
# endif
+# include <sys/wait.h>
# ifdef I_UTIME
# include <utime.h>
# endif
#endif
/* Possibly needed prototypes */
-char *cuserid (char *);
#ifndef WIN32
double strtod (const char *, char **);
long strtol (const char *, char **, int);
unsigned long strtoul (const char *, char **, int);
#endif
-#ifndef HAS_CUSERID
-#define cuserid(a) (char *) not_here("cuserid")
-#endif
#ifndef HAS_DIFFTIME
#ifndef difftime
#define difftime(a,b) not_here("difftime")
* to follow the traditional. However, to make the POSIX
* wait W*() macros to work in BeOS, we need to unbend the
* reality back in place. --jhi */
-#ifdef __BEOS__
+/* In actual fact the code below is to blame here. Perl has an internal
+ * representation of the exit status ($?), which it re-composes from the
+ * OS's representation using the W*() POSIX macros. The code below
+ * incorrectly uses the W*() macros on the internal representation,
+ * which fails for OSs that have a different representation (namely BeOS
+ * and Haiku). WMUNGE() is a hack that converts the internal
+ * representation into the OS specific one, so that the W*() macros work
+ * as expected. The better solution would be not to use the W*() macros
+ * in the first place, though. -- Ingo Weinhold
+ */
+#if defined(__BEOS__) || defined(__HAIKU__)
# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
#else
# define WMUNGE(x) (x)
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
}
+#ifdef WIN32
+
+/*
+ * (1) The CRT maintains its own copy of the environment, separate from
+ * the Win32API copy.
+ *
+ * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
+ * copy, and then calls SetEnvironmentVariableA() to update the Win32API
+ * copy.
+ *
+ * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
+ * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
+ * environment.
+ *
+ * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
+ * calls CRT tzset(), but only the first time it is called, and in turn
+ * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
+ * local copy of the environment and hence gets the original setting as
+ * perl never updates the CRT copy when assigning to $ENV{TZ}.
+ *
+ * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
+ * putenv() to update the CRT copy of the environment (if it is different)
+ * whenever we're about to call tzset().
+ *
+ * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
+ * defined:
+ *
+ * (a) Each interpreter has its own copy of the environment inside the
+ * perlhost structure. That allows applications that host multiple
+ * independent Perl interpreters to isolate environment changes from
+ * each other. (This is similar to how the perlhost mechanism keeps a
+ * separate working directory for each Perl interpreter, so that calling
+ * chdir() will not affect other interpreters.)
+ *
+ * (b) Only the first Perl interpreter instantiated within a process will
+ * "write through" environment changes to the process environment.
+ *
+ * (c) Even the primary Perl interpreter won't update the CRT copy of the
+ * the environment, only the Win32API copy (it calls win32_putenv()).
+ *
+ * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
+ * sense to only update the process environment when inside the main
+ * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
+ * from here so we'll just have to check PL_curinterp instead.
+ *
+ * Therefore, we can simply #undef getenv() and putenv() so that those names
+ * always refer to the CRT functions, and explicitly call win32_getenv() to
+ * access perl's %ENV.
+ *
+ * We also #undef malloc() and free() to be sure we are using the CRT
+ * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
+ * into VMem::Malloc() and VMem::Free() and all allocations will be freed
+ * when the Perl interpreter is being destroyed so we'd end up with a pointer
+ * into deallocated memory in environ[] if a program embedding a Perl
+ * interpreter continues to operate even after the main Perl interpreter has
+ * been destroyed.
+ *
+ * Note that we don't free() the malloc()ed memory unless and until we call
+ * malloc() again ourselves because the CRT putenv() function simply puts its
+ * pointer argument into the environ[] arrary (it doesn't make a copy of it)
+ * so this memory must otherwise be leaked.
+ */
+
+#undef getenv
+#undef putenv
+#undef malloc
+#undef free
+
+static void
+fix_win32_tzenv(void)
+{
+ static char* oldenv = NULL;
+ char* newenv;
+ const char* perl_tz_env = win32_getenv("TZ");
+ const char* crt_tz_env = getenv("TZ");
+ if (perl_tz_env == NULL)
+ perl_tz_env = "";
+ if (crt_tz_env == NULL)
+ crt_tz_env = "";
+ if (strcmp(perl_tz_env, crt_tz_env) != 0) {
+ newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
+ if (newenv != NULL) {
+ sprintf(newenv, "TZ=%s", perl_tz_env);
+ putenv(newenv);
+ if (oldenv != NULL)
+ free(oldenv);
+ oldenv = newenv;
+ }
+ }
+}
+
+#endif
+
+/*
+ * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
+ * This code is duplicated in the Time-Piece module, so any changes made here
+ * should be made there too.
+ */
+static void
+my_tzset(pTHX)
+{
+#ifdef WIN32
+#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
+ if (PL_curinterp == aTHX)
+#endif
+ fix_win32_tzenv();
+#endif
+ tzset();
+}
+
MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
POSIX::SigSet
POSIX::WSTOPSIG = 4
POSIX::WTERMSIG = 5
CODE:
+#if !(defined(WEXITSTATUS) || defined(WIFEXITED) || defined(WIFSIGNALED) \
+ || defined(WIFSTOPPED) || defined(WSTOPSIG) || defined (WTERMSIG))
+ RETVAL = 0; /* Silence compilers that notice this, but don't realise
+ that not_here() can't return. */
+#endif
switch(ix) {
case 0:
- RETVAL = WEXITSTATUS(status);
+#ifdef WEXITSTATUS
+ RETVAL = WEXITSTATUS(WMUNGE(status));
+#else
+ not_here("WEXITSTATUS");
+#endif
break;
case 1:
- RETVAL = WIFEXITED(status);
+#ifdef WIFEXITED
+ RETVAL = WIFEXITED(WMUNGE(status));
+#else
+ not_here("WIFEXITED");
+#endif
break;
case 2:
- RETVAL = WIFSIGNALED(status);
+#ifdef WIFSIGNALED
+ RETVAL = WIFSIGNALED(WMUNGE(status));
+#else
+ not_here("WIFSIGNALED");
+#endif
break;
case 3:
- RETVAL = WIFSTOPPED(status);
+#ifdef WIFSTOPPED
+ RETVAL = WIFSTOPPED(WMUNGE(status));
+#else
+ not_here("WIFSTOPPED");
+#endif
break;
case 4:
- RETVAL = WSTOPSIG(status);
+#ifdef WSTOPSIG
+ RETVAL = WSTOPSIG(WMUNGE(status));
+#else
+ not_here("WSTOPSIG");
+#endif
break;
case 5:
- RETVAL = WTERMSIG(status);
+#ifdef WTERMSIG
+ RETVAL = WTERMSIG(WMUNGE(status));
+#else
+ not_here("WTERMSIG");
+#endif
break;
default:
Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", ix);
void
tzset()
+ PPCODE:
+ my_tzset(aTHX);
void
tzname()
char *
cuserid(s = 0)
char * s = 0;
+ CODE:
+#ifdef HAS_CUSERID
+ RETVAL = cuserid(s);
+#else
+ RETVAL = 0;
+ not_here("cuserid");
+#endif
+ OUTPUT:
+ RETVAL
SysRetLong
fpathconf(fd, name)
projects / p5sagit/p5-mst-13.2.git / blobdiff