f9a91ca8b26f8dfb1f80b2c06441134029bdac5b
[perl.git] / ext / POSIX / POSIX.xs
1 #define PERL_EXT_POSIX
2
3 #ifdef NETWARE
4         #define _POSIX_
5         /*
6          * Ideally this should be somewhere down in the includes
7          * but putting it in other places is giving compiler errors.
8          * Also here I am unable to check for HAS_UNAME since it wouldn't have
9          * yet come into the file at this stage - sgp 18th Oct 2000
10          */
11         #include <sys/utsname.h>
12 #endif  /* NETWARE */
13
14 #define PERL_NO_GET_CONTEXT
15
16 #include "EXTERN.h"
17 #define PERLIO_NOT_STDIO 1
18 #include "perl.h"
19 #include "XSUB.h"
20 #if defined(PERL_IMPLICIT_SYS)
21 #  undef signal
22 #  undef open
23 #  undef setmode
24 #  define open PerlLIO_open3
25 #endif
26 #include <ctype.h>
27 #ifdef I_DIRENT    /* XXX maybe better to just rely on perl.h? */
28 #include <dirent.h>
29 #endif
30 #include <errno.h>
31 #ifdef I_FLOAT
32 #include <float.h>
33 #endif
34 #ifdef I_LIMITS
35 #include <limits.h>
36 #endif
37 #include <locale.h>
38 #include <math.h>
39 #ifdef I_PWD
40 #include <pwd.h>
41 #endif
42 #include <setjmp.h>
43 #include <signal.h>
44 #include <stdarg.h>
45
46 #ifdef I_STDDEF
47 #include <stddef.h>
48 #endif
49
50 #ifdef I_UNISTD
51 #include <unistd.h>
52 #endif
53
54 /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
55    metaconfig for future extension writers.  We don't use them in POSIX.
56    (This is really sneaky :-)  --AD
57 */
58 #if defined(I_TERMIOS)
59 #include <termios.h>
60 #endif
61 #ifdef I_STDLIB
62 #include <stdlib.h>
63 #endif
64 #ifndef __ultrix__
65 #include <string.h>
66 #endif
67 #include <sys/stat.h>
68 #include <sys/types.h>
69 #include <time.h>
70 #ifdef I_UNISTD
71 #include <unistd.h>
72 #endif
73 #include <fcntl.h>
74
75 #ifdef HAS_TZNAME
76 #  if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
77 extern char *tzname[];
78 #  endif
79 #else
80 #if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
81 char *tzname[] = { "" , "" };
82 #endif
83 #endif
84
85 #if defined(__VMS) && !defined(__POSIX_SOURCE)
86 #  include <libdef.h>       /* LIB$_INVARG constant */
87 #  include <lib$routines.h> /* prototype for lib$ediv() */
88 #  include <starlet.h>      /* prototype for sys$gettim() */
89 #  if DECC_VERSION < 50000000
90 #    define pid_t int       /* old versions of DECC miss this in types.h */
91 #  endif
92
93 #  undef mkfifo
94 #  define mkfifo(a,b) (not_here("mkfifo"),-1)
95 #  define tzset() not_here("tzset")
96
97 #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
98 #    define HAS_TZNAME  /* shows up in VMS 7.0 or Dec C 5.6 */
99 #    include <utsname.h>
100 #  endif /* __VMS_VER >= 70000000 or Dec C 5.6 */
101
102    /* The POSIX notion of ttyname() is better served by getname() under VMS */
103    static char ttnambuf[64];
104 #  define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
105
106    /* The non-POSIX CRTL times() has void return type, so we just get the
107       current time directly */
108    clock_t vms_times(struct tms *bufptr) {
109         dTHX;
110         clock_t retval;
111         /* Get wall time and convert to 10 ms intervals to
112          * produce the return value that the POSIX standard expects */
113 #  if defined(__DECC) && defined (__ALPHA)
114 #    include <ints.h>
115         uint64 vmstime;
116         _ckvmssts(sys$gettim(&vmstime));
117         vmstime /= 100000;
118         retval = vmstime & 0x7fffffff;
119 #  else
120         /* (Older hw or ccs don't have an atomic 64-bit type, so we
121          * juggle 32-bit ints (and a float) to produce a time_t result
122          * with minimal loss of information.) */
123         long int vmstime[2],remainder,divisor = 100000;
124         _ckvmssts(sys$gettim((unsigned long int *)vmstime));
125         vmstime[1] &= 0x7fff;  /* prevent overflow in EDIV */
126         _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
127 #  endif
128         /* Fill in the struct tms using the CRTL routine . . .*/
129         times((tbuffer_t *)bufptr);
130         return (clock_t) retval;
131    }
132 #  define times(t) vms_times(t)
133 #else
134 #if defined (__CYGWIN__)
135 #    define tzname _tzname
136 #endif
137 #if defined (WIN32) || defined (NETWARE)
138 #  undef mkfifo
139 #  define mkfifo(a,b) not_here("mkfifo")
140 #  define ttyname(a) (char*)not_here("ttyname")
141 #  define sigset_t long
142 #  define pid_t long
143 #  ifdef _MSC_VER
144 #    define mode_t short
145 #  endif
146 #  ifdef __MINGW32__
147 #    define mode_t short
148 #    ifndef tzset
149 #      define tzset()           not_here("tzset")
150 #    endif
151 #    ifndef _POSIX_OPEN_MAX
152 #      define _POSIX_OPEN_MAX   FOPEN_MAX       /* XXX bogus ? */
153 #    endif
154 #  endif
155 #  define sigaction(a,b,c)      not_here("sigaction")
156 #  define sigpending(a)         not_here("sigpending")
157 #  define sigprocmask(a,b,c)    not_here("sigprocmask")
158 #  define sigsuspend(a)         not_here("sigsuspend")
159 #  define sigemptyset(a)        not_here("sigemptyset")
160 #  define sigaddset(a,b)        not_here("sigaddset")
161 #  define sigdelset(a,b)        not_here("sigdelset")
162 #  define sigfillset(a)         not_here("sigfillset")
163 #  define sigismember(a,b)      not_here("sigismember")
164 #ifndef NETWARE
165 #  undef setuid
166 #  undef setgid
167 #  define setuid(a)             not_here("setuid")
168 #  define setgid(a)             not_here("setgid")
169 #endif  /* NETWARE */
170 #else
171
172 #  ifndef HAS_MKFIFO
173 #    if defined(OS2)
174 #      define mkfifo(a,b) not_here("mkfifo")
175 #    else       /* !( defined OS2 ) */
176 #      ifndef mkfifo
177 #        define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
178 #      endif
179 #    endif
180 #  endif /* !HAS_MKFIFO */
181
182 #  ifdef I_GRP
183 #    include <grp.h>
184 #  endif
185 #  include <sys/times.h>
186 #  ifdef HAS_UNAME
187 #    include <sys/utsname.h>
188 #  endif
189 #  include <sys/wait.h>
190 #  ifdef I_UTIME
191 #    include <utime.h>
192 #  endif
193 #endif /* WIN32 || NETWARE */
194 #endif /* __VMS */
195
196 #ifdef WIN32
197    /* Perl on Windows assigns WSAGetLastError() return values to errno
198     * (in win32/win32sck.c).  Therefore we need to map these values
199     * back to standard symbolic names, but only for those names having
200     * no existing value or an existing value >= 100. (VC++ 2010 defines
201     * a group of names with values >= 100 in its errno.h which we *do*
202     * need to redefine.) The Errno.pm module does a similar mapping.
203     */
204 #  ifdef EWOULDBLOCK
205 #    undef EWOULDBLOCK
206 #  endif
207 #  define EWOULDBLOCK WSAEWOULDBLOCK
208 #  ifdef EINPROGRESS
209 #    undef EINPROGRESS
210 #  endif
211 #  define EINPROGRESS WSAEINPROGRESS
212 #  ifdef EALREADY
213 #    undef EALREADY
214 #  endif
215 #  define EALREADY WSAEALREADY
216 #  ifdef ENOTSOCK
217 #    undef ENOTSOCK
218 #  endif
219 #  define ENOTSOCK WSAENOTSOCK
220 #  ifdef EDESTADDRREQ
221 #    undef EDESTADDRREQ
222 #  endif
223 #  define EDESTADDRREQ WSAEDESTADDRREQ
224 #  ifdef EMSGSIZE
225 #    undef EMSGSIZE
226 #  endif
227 #  define EMSGSIZE WSAEMSGSIZE
228 #  ifdef EPROTOTYPE
229 #    undef EPROTOTYPE
230 #  endif
231 #  define EPROTOTYPE WSAEPROTOTYPE
232 #  ifdef ENOPROTOOPT
233 #    undef ENOPROTOOPT
234 #  endif
235 #  define ENOPROTOOPT WSAENOPROTOOPT
236 #  ifdef EPROTONOSUPPORT
237 #    undef EPROTONOSUPPORT
238 #  endif
239 #  define EPROTONOSUPPORT WSAEPROTONOSUPPORT
240 #  ifdef ESOCKTNOSUPPORT
241 #    undef ESOCKTNOSUPPORT
242 #  endif
243 #  define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT
244 #  ifdef EOPNOTSUPP
245 #    undef EOPNOTSUPP
246 #  endif
247 #  define EOPNOTSUPP WSAEOPNOTSUPP
248 #  ifdef EPFNOSUPPORT
249 #    undef EPFNOSUPPORT
250 #  endif
251 #  define EPFNOSUPPORT WSAEPFNOSUPPORT
252 #  ifdef EAFNOSUPPORT
253 #    undef EAFNOSUPPORT
254 #  endif
255 #  define EAFNOSUPPORT WSAEAFNOSUPPORT
256 #  ifdef EADDRINUSE
257 #    undef EADDRINUSE
258 #  endif
259 #  define EADDRINUSE WSAEADDRINUSE
260 #  ifdef EADDRNOTAVAIL
261 #    undef EADDRNOTAVAIL
262 #  endif
263 #  define EADDRNOTAVAIL WSAEADDRNOTAVAIL
264 #  ifdef ENETDOWN
265 #    undef ENETDOWN
266 #  endif
267 #  define ENETDOWN WSAENETDOWN
268 #  ifdef ENETUNREACH
269 #    undef ENETUNREACH
270 #  endif
271 #  define ENETUNREACH WSAENETUNREACH
272 #  ifdef ENETRESET
273 #    undef ENETRESET
274 #  endif
275 #  define ENETRESET WSAENETRESET
276 #  ifdef ECONNABORTED
277 #    undef ECONNABORTED
278 #  endif
279 #  define ECONNABORTED WSAECONNABORTED
280 #  ifdef ECONNRESET
281 #    undef ECONNRESET
282 #  endif
283 #  define ECONNRESET WSAECONNRESET
284 #  ifdef ENOBUFS
285 #    undef ENOBUFS
286 #  endif
287 #  define ENOBUFS WSAENOBUFS
288 #  ifdef EISCONN
289 #    undef EISCONN
290 #  endif
291 #  define EISCONN WSAEISCONN
292 #  ifdef ENOTCONN
293 #    undef ENOTCONN
294 #  endif
295 #  define ENOTCONN WSAENOTCONN
296 #  ifdef ESHUTDOWN
297 #    undef ESHUTDOWN
298 #  endif
299 #  define ESHUTDOWN WSAESHUTDOWN
300 #  ifdef ETOOMANYREFS
301 #    undef ETOOMANYREFS
302 #  endif
303 #  define ETOOMANYREFS WSAETOOMANYREFS
304 #  ifdef ETIMEDOUT
305 #    undef ETIMEDOUT
306 #  endif
307 #  define ETIMEDOUT WSAETIMEDOUT
308 #  ifdef ECONNREFUSED
309 #    undef ECONNREFUSED
310 #  endif
311 #  define ECONNREFUSED WSAECONNREFUSED
312 #  ifdef ELOOP
313 #    undef ELOOP
314 #  endif
315 #  define ELOOP WSAELOOP
316 #  ifdef EHOSTDOWN
317 #    undef EHOSTDOWN
318 #  endif
319 #  define EHOSTDOWN WSAEHOSTDOWN
320 #  ifdef EHOSTUNREACH
321 #    undef EHOSTUNREACH
322 #  endif
323 #  define EHOSTUNREACH WSAEHOSTUNREACH
324 #  ifdef EPROCLIM
325 #    undef EPROCLIM
326 #  endif
327 #  define EPROCLIM WSAEPROCLIM
328 #  ifdef EUSERS
329 #    undef EUSERS
330 #  endif
331 #  define EUSERS WSAEUSERS
332 #  ifdef EDQUOT
333 #    undef EDQUOT
334 #  endif
335 #  define EDQUOT WSAEDQUOT
336 #  ifdef ESTALE
337 #    undef ESTALE
338 #  endif
339 #  define ESTALE WSAESTALE
340 #  ifdef EREMOTE
341 #    undef EREMOTE
342 #  endif
343 #  define EREMOTE WSAEREMOTE
344 #  ifdef EDISCON
345 #    undef EDISCON
346 #  endif
347 #  define EDISCON WSAEDISCON
348 #endif
349
350 typedef int SysRet;
351 typedef long SysRetLong;
352 typedef sigset_t* POSIX__SigSet;
353 typedef HV* POSIX__SigAction;
354 #ifdef I_TERMIOS
355 typedef struct termios* POSIX__Termios;
356 #else /* Define termios types to int, and call not_here for the functions.*/
357 #define POSIX__Termios int
358 #define speed_t int
359 #define tcflag_t int
360 #define cc_t int
361 #define cfgetispeed(x) not_here("cfgetispeed")
362 #define cfgetospeed(x) not_here("cfgetospeed")
363 #define tcdrain(x) not_here("tcdrain")
364 #define tcflush(x,y) not_here("tcflush")
365 #define tcsendbreak(x,y) not_here("tcsendbreak")
366 #define cfsetispeed(x,y) not_here("cfsetispeed")
367 #define cfsetospeed(x,y) not_here("cfsetospeed")
368 #define ctermid(x) (char *) not_here("ctermid")
369 #define tcflow(x,y) not_here("tcflow")
370 #define tcgetattr(x,y) not_here("tcgetattr")
371 #define tcsetattr(x,y,z) not_here("tcsetattr")
372 #endif
373
374 /* Possibly needed prototypes */
375 #ifndef WIN32
376 double strtod (const char *, char **);
377 long strtol (const char *, char **, int);
378 unsigned long strtoul (const char *, char **, int);
379 #endif
380
381 #ifndef HAS_DIFFTIME
382 #ifndef difftime
383 #define difftime(a,b) not_here("difftime")
384 #endif
385 #endif
386 #ifndef HAS_FPATHCONF
387 #define fpathconf(f,n)  (SysRetLong) not_here("fpathconf")
388 #endif
389 #ifndef HAS_MKTIME
390 #define mktime(a) not_here("mktime")
391 #endif
392 #ifndef HAS_NICE
393 #define nice(a) not_here("nice")
394 #endif
395 #ifndef HAS_PATHCONF
396 #define pathconf(f,n)   (SysRetLong) not_here("pathconf")
397 #endif
398 #ifndef HAS_SYSCONF
399 #define sysconf(n)      (SysRetLong) not_here("sysconf")
400 #endif
401 #ifndef HAS_READLINK
402 #define readlink(a,b,c) not_here("readlink")
403 #endif
404 #ifndef HAS_SETPGID
405 #define setpgid(a,b) not_here("setpgid")
406 #endif
407 #ifndef HAS_SETSID
408 #define setsid() not_here("setsid")
409 #endif
410 #ifndef HAS_STRCOLL
411 #define strcoll(s1,s2) not_here("strcoll")
412 #endif
413 #ifndef HAS_STRTOD
414 #define strtod(s1,s2) not_here("strtod")
415 #endif
416 #ifndef HAS_STRTOL
417 #define strtol(s1,s2,b) not_here("strtol")
418 #endif
419 #ifndef HAS_STRTOUL
420 #define strtoul(s1,s2,b) not_here("strtoul")
421 #endif
422 #ifndef HAS_STRXFRM
423 #define strxfrm(s1,s2,n) not_here("strxfrm")
424 #endif
425 #ifndef HAS_TCGETPGRP
426 #define tcgetpgrp(a) not_here("tcgetpgrp")
427 #endif
428 #ifndef HAS_TCSETPGRP
429 #define tcsetpgrp(a,b) not_here("tcsetpgrp")
430 #endif
431 #ifndef HAS_TIMES
432 #ifndef NETWARE
433 #define times(a) not_here("times")
434 #endif  /* NETWARE */
435 #endif
436 #ifndef HAS_UNAME
437 #define uname(a) not_here("uname")
438 #endif
439 #ifndef HAS_WAITPID
440 #define waitpid(a,b,c) not_here("waitpid")
441 #endif
442
443 #ifndef HAS_MBLEN
444 #ifndef mblen
445 #define mblen(a,b) not_here("mblen")
446 #endif
447 #endif
448 #ifndef HAS_MBSTOWCS
449 #define mbstowcs(s, pwcs, n) not_here("mbstowcs")
450 #endif
451 #ifndef HAS_MBTOWC
452 #define mbtowc(pwc, s, n) not_here("mbtowc")
453 #endif
454 #ifndef HAS_WCSTOMBS
455 #define wcstombs(s, pwcs, n) not_here("wcstombs")
456 #endif
457 #ifndef HAS_WCTOMB
458 #define wctomb(s, wchar) not_here("wcstombs")
459 #endif
460 #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
461 /* If we don't have these functions, then we wouldn't have gotten a typedef
462    for wchar_t, the wide character type.  Defining wchar_t allows the
463    functions referencing it to compile.  Its actual type is then meaningless,
464    since without the above functions, all sections using it end up calling
465    not_here() and croak.  --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
466 #ifndef wchar_t
467 #define wchar_t char
468 #endif
469 #endif
470
471 #ifdef HAS_LOCALECONV
472 struct lconv_offset {
473     const char *name;
474     size_t offset;
475 };
476
477 const struct lconv_offset lconv_strings[] = {
478     {"decimal_point",     offsetof(struct lconv, decimal_point)},
479     {"thousands_sep",     offsetof(struct lconv, thousands_sep)},
480 #ifndef NO_LOCALECONV_GROUPING
481     {"grouping",          offsetof(struct lconv, grouping)},
482 #endif
483     {"int_curr_symbol",   offsetof(struct lconv, int_curr_symbol)},
484     {"currency_symbol",   offsetof(struct lconv, currency_symbol)},
485     {"mon_decimal_point", offsetof(struct lconv, mon_decimal_point)},
486 #ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
487     {"mon_thousands_sep", offsetof(struct lconv, mon_thousands_sep)},
488 #endif
489 #ifndef NO_LOCALECONV_MON_GROUPING
490     {"mon_grouping",      offsetof(struct lconv, mon_grouping)},
491 #endif
492     {"positive_sign",     offsetof(struct lconv, positive_sign)},
493     {"negative_sign",     offsetof(struct lconv, negative_sign)},
494     {NULL, 0}
495 };
496
497 const struct lconv_offset lconv_integers[] = {
498     {"int_frac_digits",   offsetof(struct lconv, int_frac_digits)},
499     {"frac_digits",       offsetof(struct lconv, frac_digits)},
500     {"p_cs_precedes",     offsetof(struct lconv, p_cs_precedes)},
501     {"p_sep_by_space",    offsetof(struct lconv, p_sep_by_space)},
502     {"n_cs_precedes",     offsetof(struct lconv, n_cs_precedes)},
503     {"n_sep_by_space",    offsetof(struct lconv, n_sep_by_space)},
504     {"p_sign_posn",       offsetof(struct lconv, p_sign_posn)},
505     {"n_sign_posn",       offsetof(struct lconv, n_sign_posn)},
506     {NULL, 0}
507 };
508
509 #else
510 #define localeconv() not_here("localeconv")
511 #endif
512
513 #ifdef HAS_LONG_DOUBLE
514 #  if LONG_DOUBLESIZE > NVSIZE
515 #    undef HAS_LONG_DOUBLE  /* XXX until we figure out how to use them */
516 #  endif
517 #endif
518
519 #ifndef HAS_LONG_DOUBLE
520 #ifdef LDBL_MAX
521 #undef LDBL_MAX
522 #endif
523 #ifdef LDBL_MIN
524 #undef LDBL_MIN
525 #endif
526 #ifdef LDBL_EPSILON
527 #undef LDBL_EPSILON
528 #endif
529 #endif
530
531 /* Background: in most systems the low byte of the wait status
532  * is the signal (the lowest 7 bits) and the coredump flag is
533  * the eight bit, and the second lowest byte is the exit status.
534  * BeOS bucks the trend and has the bytes in different order.
535  * See beos/beos.c for how the reality is bent even in BeOS
536  * to follow the traditional.  However, to make the POSIX
537  * wait W*() macros to work in BeOS, we need to unbend the
538  * reality back in place. --jhi */
539 /* In actual fact the code below is to blame here. Perl has an internal
540  * representation of the exit status ($?), which it re-composes from the
541  * OS's representation using the W*() POSIX macros. The code below
542  * incorrectly uses the W*() macros on the internal representation,
543  * which fails for OSs that have a different representation (namely BeOS
544  * and Haiku). WMUNGE() is a hack that converts the internal
545  * representation into the OS specific one, so that the W*() macros work
546  * as expected. The better solution would be not to use the W*() macros
547  * in the first place, though. -- Ingo Weinhold
548  */
549 #if defined(__BEOS__) || defined(__HAIKU__)
550 #    define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
551 #else
552 #    define WMUNGE(x) (x)
553 #endif
554
555 static int
556 not_here(const char *s)
557 {
558     croak("POSIX::%s not implemented on this architecture", s);
559     return -1;
560 }
561
562 #include "const-c.inc"
563
564 static void
565 restore_sigmask(pTHX_ SV *osset_sv)
566 {
567      /* Fortunately, restoring the signal mask can't fail, because
568       * there's nothing we can do about it if it does -- we're not
569       * supposed to return -1 from sigaction unless the disposition
570       * was unaffected.
571       */
572      sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
573      (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
574 }
575
576 static void *
577 allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
578     SV *const t = newSVrv(rv, packname);
579     void *const p = sv_grow(t, size + 1);
580
581     SvCUR_set(t, size);
582     SvPOK_on(t);
583     return p;
584 }
585
586 #ifdef WIN32
587
588 /*
589  * (1) The CRT maintains its own copy of the environment, separate from
590  * the Win32API copy.
591  *
592  * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
593  * copy, and then calls SetEnvironmentVariableA() to update the Win32API
594  * copy.
595  *
596  * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
597  * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
598  * environment.
599  *
600  * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
601  * calls CRT tzset(), but only the first time it is called, and in turn
602  * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
603  * local copy of the environment and hence gets the original setting as
604  * perl never updates the CRT copy when assigning to $ENV{TZ}.
605  *
606  * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
607  * putenv() to update the CRT copy of the environment (if it is different)
608  * whenever we're about to call tzset().
609  *
610  * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
611  * defined:
612  *
613  * (a) Each interpreter has its own copy of the environment inside the
614  * perlhost structure. That allows applications that host multiple
615  * independent Perl interpreters to isolate environment changes from
616  * each other. (This is similar to how the perlhost mechanism keeps a
617  * separate working directory for each Perl interpreter, so that calling
618  * chdir() will not affect other interpreters.)
619  *
620  * (b) Only the first Perl interpreter instantiated within a process will
621  * "write through" environment changes to the process environment.
622  *
623  * (c) Even the primary Perl interpreter won't update the CRT copy of the
624  * the environment, only the Win32API copy (it calls win32_putenv()).
625  *
626  * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
627  * sense to only update the process environment when inside the main
628  * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
629  * from here so we'll just have to check PL_curinterp instead.
630  *
631  * Therefore, we can simply #undef getenv() and putenv() so that those names
632  * always refer to the CRT functions, and explicitly call win32_getenv() to
633  * access perl's %ENV.
634  *
635  * We also #undef malloc() and free() to be sure we are using the CRT
636  * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
637  * into VMem::Malloc() and VMem::Free() and all allocations will be freed
638  * when the Perl interpreter is being destroyed so we'd end up with a pointer
639  * into deallocated memory in environ[] if a program embedding a Perl
640  * interpreter continues to operate even after the main Perl interpreter has
641  * been destroyed.
642  *
643  * Note that we don't free() the malloc()ed memory unless and until we call
644  * malloc() again ourselves because the CRT putenv() function simply puts its
645  * pointer argument into the environ[] array (it doesn't make a copy of it)
646  * so this memory must otherwise be leaked.
647  */
648
649 #undef getenv
650 #undef putenv
651 #undef malloc
652 #undef free
653
654 static void
655 fix_win32_tzenv(void)
656 {
657     static char* oldenv = NULL;
658     char* newenv;
659     const char* perl_tz_env = win32_getenv("TZ");
660     const char* crt_tz_env = getenv("TZ");
661     if (perl_tz_env == NULL)
662         perl_tz_env = "";
663     if (crt_tz_env == NULL)
664         crt_tz_env = "";
665     if (strcmp(perl_tz_env, crt_tz_env) != 0) {
666         newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
667         if (newenv != NULL) {
668             sprintf(newenv, "TZ=%s", perl_tz_env);
669             putenv(newenv);
670             if (oldenv != NULL)
671                 free(oldenv);
672             oldenv = newenv;
673         }
674     }
675 }
676
677 #endif
678
679 /*
680  * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
681  * This code is duplicated in the Time-Piece module, so any changes made here
682  * should be made there too.
683  */
684 static void
685 my_tzset(pTHX)
686 {
687 #ifdef WIN32
688 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
689     if (PL_curinterp == aTHX)
690 #endif
691         fix_win32_tzenv();
692 #endif
693     tzset();
694 }
695
696 typedef int (*isfunc_t)(int);
697 typedef void (*any_dptr_t)(void *);
698
699 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
700    a regular XSUB.  */
701 static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */
702 static XSPROTO(is_common)
703 {
704     dXSARGS;
705     SV *charstring;
706     if (items != 1)
707        croak_xs_usage(cv,  "charstring");
708
709     {
710         dXSTARG;
711         STRLEN  len;
712         int     RETVAL;
713         unsigned char *s = (unsigned char *) SvPV(ST(0), len);
714         unsigned char *e = s + len;
715         isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
716
717         for (RETVAL = 1; RETVAL && s < e; s++)
718             if (!isfunc(*s))
719                 RETVAL = 0;
720         XSprePUSH;
721         PUSHi((IV)RETVAL);
722     }
723     XSRETURN(1);
724 }
725
726 MODULE = POSIX          PACKAGE = POSIX
727
728 BOOT:
729 {
730     CV *cv;
731     const char *file = __FILE__;
732
733     /* Ensure we get the function, not a macro implementation. Like the C89
734        standard says we can...  */
735 #undef isalnum
736     cv = newXS("POSIX::isalnum", is_common, file);
737     XSANY.any_dptr = (any_dptr_t) &isalnum;
738 #undef isalpha
739     cv = newXS("POSIX::isalpha", is_common, file);
740     XSANY.any_dptr = (any_dptr_t) &isalpha;
741 #undef iscntrl
742     cv = newXS("POSIX::iscntrl", is_common, file);
743     XSANY.any_dptr = (any_dptr_t) &iscntrl;
744 #undef isdigit
745     cv = newXS("POSIX::isdigit", is_common, file);
746     XSANY.any_dptr = (any_dptr_t) &isdigit;
747 #undef isgraph
748     cv = newXS("POSIX::isgraph", is_common, file);
749     XSANY.any_dptr = (any_dptr_t) &isgraph;
750 #undef islower
751     cv = newXS("POSIX::islower", is_common, file);
752     XSANY.any_dptr = (any_dptr_t) &islower;
753 #undef isprint
754     cv = newXS("POSIX::isprint", is_common, file);
755     XSANY.any_dptr = (any_dptr_t) &isprint;
756 #undef ispunct
757     cv = newXS("POSIX::ispunct", is_common, file);
758     XSANY.any_dptr = (any_dptr_t) &ispunct;
759 #undef isspace
760     cv = newXS("POSIX::isspace", is_common, file);
761     XSANY.any_dptr = (any_dptr_t) &isspace;
762 #undef isupper
763     cv = newXS("POSIX::isupper", is_common, file);
764     XSANY.any_dptr = (any_dptr_t) &isupper;
765 #undef isxdigit
766     cv = newXS("POSIX::isxdigit", is_common, file);
767     XSANY.any_dptr = (any_dptr_t) &isxdigit;
768 }
769
770 MODULE = SigSet         PACKAGE = POSIX::SigSet         PREFIX = sig
771
772 void
773 new(packname = "POSIX::SigSet", ...)
774     const char *        packname
775     CODE:
776         {
777             int i;
778             sigset_t *const s
779                 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
780                                                sizeof(sigset_t),
781                                                packname);
782             sigemptyset(s);
783             for (i = 1; i < items; i++)
784                 sigaddset(s, SvIV(ST(i)));
785             XSRETURN(1);
786         }
787
788 SysRet
789 addset(sigset, sig)
790         POSIX::SigSet   sigset
791         int             sig
792    ALIAS:
793         delset = 1
794    CODE:
795         RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
796    OUTPUT:
797         RETVAL
798
799 SysRet
800 emptyset(sigset)
801         POSIX::SigSet   sigset
802    ALIAS:
803         fillset = 1
804    CODE:
805         RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
806    OUTPUT:
807         RETVAL
808
809 int
810 sigismember(sigset, sig)
811         POSIX::SigSet   sigset
812         int             sig
813
814 MODULE = Termios        PACKAGE = POSIX::Termios        PREFIX = cf
815
816 void
817 new(packname = "POSIX::Termios", ...)
818     const char *        packname
819     CODE:
820         {
821 #ifdef I_TERMIOS
822             void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
823                                             sizeof(struct termios), packname);
824             /* The previous implementation stored a pointer to an uninitialised
825                struct termios. Seems safer to initialise it, particularly as
826                this implementation exposes the struct to prying from perl-space.
827             */
828             memset(p, 0, 1 + sizeof(struct termios));
829             XSRETURN(1);
830 #else
831             not_here("termios");
832 #endif
833         }
834
835 SysRet
836 getattr(termios_ref, fd = 0)
837         POSIX::Termios  termios_ref
838         int             fd
839     CODE:
840         RETVAL = tcgetattr(fd, termios_ref);
841     OUTPUT:
842         RETVAL
843
844 # If we define TCSANOW here then both a found and not found constant sub
845 # are created causing a Constant subroutine TCSANOW redefined warning
846 #ifndef TCSANOW
847 #  define DEF_SETATTR_ACTION 0
848 #else
849 #  define DEF_SETATTR_ACTION TCSANOW
850 #endif
851 SysRet
852 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
853         POSIX::Termios  termios_ref
854         int             fd
855         int             optional_actions
856     CODE:
857         /* The second argument to the call is mandatory, but we'd like to give
858            it a useful default. 0 isn't valid on all operating systems - on
859            Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
860            values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF.  */
861         RETVAL = tcsetattr(fd, optional_actions, termios_ref);
862     OUTPUT:
863         RETVAL
864
865 speed_t
866 getispeed(termios_ref)
867         POSIX::Termios  termios_ref
868     ALIAS:
869         getospeed = 1
870     CODE:
871         RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
872     OUTPUT:
873         RETVAL
874
875 tcflag_t
876 getiflag(termios_ref)
877         POSIX::Termios  termios_ref
878     ALIAS:
879         getoflag = 1
880         getcflag = 2
881         getlflag = 3
882     CODE:
883 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
884         switch(ix) {
885         case 0:
886             RETVAL = termios_ref->c_iflag;
887             break;
888         case 1:
889             RETVAL = termios_ref->c_oflag;
890             break;
891         case 2:
892             RETVAL = termios_ref->c_cflag;
893             break;
894         case 3:
895             RETVAL = termios_ref->c_lflag;
896             break;
897         }
898 #else
899         not_here(GvNAME(CvGV(cv)));
900         RETVAL = 0;
901 #endif
902     OUTPUT:
903         RETVAL
904
905 cc_t
906 getcc(termios_ref, ccix)
907         POSIX::Termios  termios_ref
908         unsigned int    ccix
909     CODE:
910 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
911         if (ccix >= NCCS)
912             croak("Bad getcc subscript");
913         RETVAL = termios_ref->c_cc[ccix];
914 #else
915      not_here("getcc");
916      RETVAL = 0;
917 #endif
918     OUTPUT:
919         RETVAL
920
921 SysRet
922 setispeed(termios_ref, speed)
923         POSIX::Termios  termios_ref
924         speed_t         speed
925     ALIAS:
926         setospeed = 1
927     CODE:
928         RETVAL = ix
929             ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
930     OUTPUT:
931         RETVAL
932
933 void
934 setiflag(termios_ref, flag)
935         POSIX::Termios  termios_ref
936         tcflag_t        flag
937     ALIAS:
938         setoflag = 1
939         setcflag = 2
940         setlflag = 3
941     CODE:
942 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
943         switch(ix) {
944         case 0:
945             termios_ref->c_iflag = flag;
946             break;
947         case 1:
948             termios_ref->c_oflag = flag;
949             break;
950         case 2:
951             termios_ref->c_cflag = flag;
952             break;
953         case 3:
954             termios_ref->c_lflag = flag;
955             break;
956         }
957 #else
958         not_here(GvNAME(CvGV(cv)));
959 #endif
960
961 void
962 setcc(termios_ref, ccix, cc)
963         POSIX::Termios  termios_ref
964         unsigned int    ccix
965         cc_t            cc
966     CODE:
967 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
968         if (ccix >= NCCS)
969             croak("Bad setcc subscript");
970         termios_ref->c_cc[ccix] = cc;
971 #else
972             not_here("setcc");
973 #endif
974
975
976 MODULE = POSIX          PACKAGE = POSIX
977
978 INCLUDE: const-xs.inc
979
980 int
981 WEXITSTATUS(status)
982         int status
983     ALIAS:
984         POSIX::WIFEXITED = 1
985         POSIX::WIFSIGNALED = 2
986         POSIX::WIFSTOPPED = 3
987         POSIX::WSTOPSIG = 4
988         POSIX::WTERMSIG = 5
989     CODE:
990 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
991       || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
992         RETVAL = 0; /* Silence compilers that notice this, but don't realise
993                        that not_here() can't return.  */
994 #endif
995         switch(ix) {
996         case 0:
997 #ifdef WEXITSTATUS
998             RETVAL = WEXITSTATUS(WMUNGE(status));
999 #else
1000             not_here("WEXITSTATUS");
1001 #endif
1002             break;
1003         case 1:
1004 #ifdef WIFEXITED
1005             RETVAL = WIFEXITED(WMUNGE(status));
1006 #else
1007             not_here("WIFEXITED");
1008 #endif
1009             break;
1010         case 2:
1011 #ifdef WIFSIGNALED
1012             RETVAL = WIFSIGNALED(WMUNGE(status));
1013 #else
1014             not_here("WIFSIGNALED");
1015 #endif
1016             break;
1017         case 3:
1018 #ifdef WIFSTOPPED
1019             RETVAL = WIFSTOPPED(WMUNGE(status));
1020 #else
1021             not_here("WIFSTOPPED");
1022 #endif
1023             break;
1024         case 4:
1025 #ifdef WSTOPSIG
1026             RETVAL = WSTOPSIG(WMUNGE(status));
1027 #else
1028             not_here("WSTOPSIG");
1029 #endif
1030             break;
1031         case 5:
1032 #ifdef WTERMSIG
1033             RETVAL = WTERMSIG(WMUNGE(status));
1034 #else
1035             not_here("WTERMSIG");
1036 #endif
1037             break;
1038         default:
1039             Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix);
1040         }
1041     OUTPUT:
1042         RETVAL
1043
1044 SysRet
1045 open(filename, flags = O_RDONLY, mode = 0666)
1046         char *          filename
1047         int             flags
1048         Mode_t          mode
1049     CODE:
1050         if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
1051             TAINT_PROPER("open");
1052         RETVAL = open(filename, flags, mode);
1053     OUTPUT:
1054         RETVAL
1055
1056
1057 HV *
1058 localeconv()
1059     CODE:
1060 #ifdef HAS_LOCALECONV
1061         struct lconv *lcbuf;
1062         RETVAL = newHV();
1063         sv_2mortal((SV*)RETVAL);
1064         if ((lcbuf = localeconv())) {
1065             const struct lconv_offset *strings = lconv_strings;
1066             const struct lconv_offset *integers = lconv_integers;
1067             const char *ptr = (const char *) lcbuf;
1068
1069             do {
1070                 const char *value = *((const char **)(ptr + strings->offset));
1071
1072                 if (value && *value)
1073                     (void) hv_store(RETVAL, strings->name, strlen(strings->name),
1074                                     newSVpv(value, 0), 0);
1075             } while ((++strings)->name);
1076
1077             do {
1078                 const char value = *((const char *)(ptr + integers->offset));
1079
1080                 if (value != CHAR_MAX)
1081                     (void) hv_store(RETVAL, integers->name,
1082                                     strlen(integers->name), newSViv(value), 0);
1083             } while ((++integers)->name);
1084         }
1085 #else
1086         localeconv(); /* A stub to call not_here(). */
1087 #endif
1088     OUTPUT:
1089         RETVAL
1090
1091 char *
1092 setlocale(category, locale = 0)
1093         int             category
1094         char *          locale
1095     PREINIT:
1096         char *          retval;
1097     CODE:
1098         retval = setlocale(category, locale);
1099         if (retval) {
1100             /* Save retval since subsequent setlocale() calls
1101              * may overwrite it. */
1102             RETVAL = savepv(retval);
1103 #ifdef USE_LOCALE_CTYPE
1104             if (category == LC_CTYPE
1105 #ifdef LC_ALL
1106                 || category == LC_ALL
1107 #endif
1108                 )
1109             {
1110                 char *newctype;
1111 #ifdef LC_ALL
1112                 if (category == LC_ALL)
1113                     newctype = setlocale(LC_CTYPE, NULL);
1114                 else
1115 #endif
1116                     newctype = RETVAL;
1117                 new_ctype(newctype);
1118             }
1119 #endif /* USE_LOCALE_CTYPE */
1120 #ifdef USE_LOCALE_COLLATE
1121             if (category == LC_COLLATE
1122 #ifdef LC_ALL
1123                 || category == LC_ALL
1124 #endif
1125                 )
1126             {
1127                 char *newcoll;
1128 #ifdef LC_ALL
1129                 if (category == LC_ALL)
1130                     newcoll = setlocale(LC_COLLATE, NULL);
1131                 else
1132 #endif
1133                     newcoll = RETVAL;
1134                 new_collate(newcoll);
1135             }
1136 #endif /* USE_LOCALE_COLLATE */
1137 #ifdef USE_LOCALE_NUMERIC
1138             if (category == LC_NUMERIC
1139 #ifdef LC_ALL
1140                 || category == LC_ALL
1141 #endif
1142                 )
1143             {
1144                 char *newnum;
1145 #ifdef LC_ALL
1146                 if (category == LC_ALL)
1147                     newnum = setlocale(LC_NUMERIC, NULL);
1148                 else
1149 #endif
1150                     newnum = RETVAL;
1151                 new_numeric(newnum);
1152             }
1153 #endif /* USE_LOCALE_NUMERIC */
1154         }
1155         else
1156             RETVAL = NULL;
1157     OUTPUT:
1158         RETVAL
1159     CLEANUP:
1160         if (RETVAL)
1161             Safefree(RETVAL);
1162
1163 NV
1164 acos(x)
1165         NV              x
1166     ALIAS:
1167         asin = 1
1168         atan = 2
1169         ceil = 3
1170         cosh = 4
1171         floor = 5
1172         log10 = 6
1173         sinh = 7
1174         tan = 8
1175         tanh = 9
1176     CODE:
1177         switch (ix) {
1178         case 0:
1179             RETVAL = acos(x);
1180             break;
1181         case 1:
1182             RETVAL = asin(x);
1183             break;
1184         case 2:
1185             RETVAL = atan(x);
1186             break;
1187         case 3:
1188             RETVAL = ceil(x);
1189             break;
1190         case 4:
1191             RETVAL = cosh(x);
1192             break;
1193         case 5:
1194             RETVAL = floor(x);
1195             break;
1196         case 6:
1197             RETVAL = log10(x);
1198             break;
1199         case 7:
1200             RETVAL = sinh(x);
1201             break;
1202         case 8:
1203             RETVAL = tan(x);
1204             break;
1205         default:
1206             RETVAL = tanh(x);
1207         }
1208     OUTPUT:
1209         RETVAL
1210
1211 NV
1212 fmod(x,y)
1213         NV              x
1214         NV              y
1215
1216 void
1217 frexp(x)
1218         NV              x
1219     PPCODE:
1220         int expvar;
1221         /* (We already know stack is long enough.) */
1222         PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
1223         PUSHs(sv_2mortal(newSViv(expvar)));
1224
1225 NV
1226 ldexp(x,exp)
1227         NV              x
1228         int             exp
1229
1230 void
1231 modf(x)
1232         NV              x
1233     PPCODE:
1234         NV intvar;
1235         /* (We already know stack is long enough.) */
1236         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
1237         PUSHs(sv_2mortal(newSVnv(intvar)));
1238
1239 SysRet
1240 sigaction(sig, optaction, oldaction = 0)
1241         int                     sig
1242         SV *                    optaction
1243         POSIX::SigAction        oldaction
1244     CODE:
1245 #if defined(WIN32) || defined(NETWARE)
1246         RETVAL = not_here("sigaction");
1247 #else
1248 # This code is really grody because we're trying to make the signal
1249 # interface look beautiful, which is hard.
1250
1251         {
1252             dVAR;
1253             POSIX__SigAction action;
1254             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
1255             struct sigaction act;
1256             struct sigaction oact;
1257             sigset_t sset;
1258             SV *osset_sv;
1259             sigset_t osset;
1260             POSIX__SigSet sigset;
1261             SV** svp;
1262             SV** sigsvp;
1263
1264             if (sig < 0) {
1265                 croak("Negative signals are not allowed");
1266             }
1267
1268             if (sig == 0 && SvPOK(ST(0))) {
1269                 const char *s = SvPVX_const(ST(0));
1270                 int i = whichsig(s);
1271
1272                 if (i < 0 && memEQ(s, "SIG", 3))
1273                     i = whichsig(s + 3);
1274                 if (i < 0) {
1275                     if (ckWARN(WARN_SIGNAL))
1276                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1277                                     "No such signal: SIG%s", s);
1278                     XSRETURN_UNDEF;
1279                 }
1280                 else
1281                     sig = i;
1282             }
1283 #ifdef NSIG
1284             if (sig > NSIG) { /* NSIG - 1 is still okay. */
1285                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1286                             "No such signal: %d", sig);
1287                 XSRETURN_UNDEF;
1288             }
1289 #endif
1290             sigsvp = hv_fetch(GvHVn(siggv),
1291                               PL_sig_name[sig],
1292                               strlen(PL_sig_name[sig]),
1293                               TRUE);
1294
1295             /* Check optaction and set action */
1296             if(SvTRUE(optaction)) {
1297                 if(sv_isa(optaction, "POSIX::SigAction"))
1298                         action = (HV*)SvRV(optaction);
1299                 else
1300                         croak("action is not of type POSIX::SigAction");
1301             }
1302             else {
1303                 action=0;
1304             }
1305
1306             /* sigaction() is supposed to look atomic. In particular, any
1307              * signal handler invoked during a sigaction() call should
1308              * see either the old or the new disposition, and not something
1309              * in between. We use sigprocmask() to make it so.
1310              */
1311             sigfillset(&sset);
1312             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
1313             if(RETVAL == -1)
1314                XSRETURN_UNDEF;
1315             ENTER;
1316             /* Restore signal mask no matter how we exit this block. */
1317             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
1318             SAVEFREESV( osset_sv );
1319             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1320
1321             RETVAL=-1; /* In case both oldaction and action are 0. */
1322
1323             /* Remember old disposition if desired. */
1324             if (oldaction) {
1325                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1326                 if(!svp)
1327                     croak("Can't supply an oldaction without a HANDLER");
1328                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
1329                         sv_setsv(*svp, *sigsvp);
1330                 }
1331                 else {
1332                         sv_setpvs(*svp, "DEFAULT");
1333                 }
1334                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
1335                 if(RETVAL == -1) {
1336                    LEAVE;
1337                    XSRETURN_UNDEF;
1338                 }
1339                 /* Get back the mask. */
1340                 svp = hv_fetchs(oldaction, "MASK", TRUE);
1341                 if (sv_isa(*svp, "POSIX::SigSet")) {
1342                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1343                 }
1344                 else {
1345                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
1346                                                           sizeof(sigset_t),
1347                                                           "POSIX::SigSet");
1348                 }
1349                 *sigset = oact.sa_mask;
1350
1351                 /* Get back the flags. */
1352                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1353                 sv_setiv(*svp, oact.sa_flags);
1354
1355                 /* Get back whether the old handler used safe signals. */
1356                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
1357                 sv_setiv(*svp,
1358                 /* compare incompatible pointers by casting to integer */
1359                     PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
1360             }
1361
1362             if (action) {
1363                 /* Safe signals use "csighandler", which vectors through the
1364                    PL_sighandlerp pointer when it's safe to do so.
1365                    (BTW, "csighandler" is very different from "sighandler".) */
1366                 svp = hv_fetchs(action, "SAFE", FALSE);
1367                 act.sa_handler =
1368                         DPTR2FPTR(
1369                             void (*)(int),
1370                             (*svp && SvTRUE(*svp))
1371                                 ? PL_csighandlerp : PL_sighandlerp
1372                         );
1373
1374                 /* Vector new Perl handler through %SIG.
1375                    (The core signal handlers read %SIG to dispatch.) */
1376                 svp = hv_fetchs(action, "HANDLER", FALSE);
1377                 if (!svp)
1378                     croak("Can't supply an action without a HANDLER");
1379                 sv_setsv(*sigsvp, *svp);
1380
1381                 /* This call actually calls sigaction() with almost the
1382                    right settings, including appropriate interpretation
1383                    of DEFAULT and IGNORE.  However, why are we doing
1384                    this when we're about to do it again just below?  XXX */
1385                 SvSETMAGIC(*sigsvp);
1386
1387                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1388                 if(SvPOK(*svp)) {
1389                         const char *s=SvPVX_const(*svp);
1390                         if(strEQ(s,"IGNORE")) {
1391                                 act.sa_handler = SIG_IGN;
1392                         }
1393                         else if(strEQ(s,"DEFAULT")) {
1394                                 act.sa_handler = SIG_DFL;
1395                         }
1396                 }
1397
1398                 /* Set up any desired mask. */
1399                 svp = hv_fetchs(action, "MASK", FALSE);
1400                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
1401                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1402                     act.sa_mask = *sigset;
1403                 }
1404                 else
1405                     sigemptyset(& act.sa_mask);
1406
1407                 /* Set up any desired flags. */
1408                 svp = hv_fetchs(action, "FLAGS", FALSE);
1409                 act.sa_flags = svp ? SvIV(*svp) : 0;
1410
1411                 /* Don't worry about cleaning up *sigsvp if this fails,
1412                  * because that means we tried to disposition a
1413                  * nonblockable signal, in which case *sigsvp is
1414                  * essentially meaningless anyway.
1415                  */
1416                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
1417                 if(RETVAL == -1) {
1418                     LEAVE;
1419                     XSRETURN_UNDEF;
1420                 }
1421             }
1422
1423             LEAVE;
1424         }
1425 #endif
1426     OUTPUT:
1427         RETVAL
1428
1429 SysRet
1430 sigpending(sigset)
1431         POSIX::SigSet           sigset
1432     ALIAS:
1433         sigsuspend = 1
1434     CODE:
1435         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
1436     OUTPUT:
1437         RETVAL
1438     CLEANUP:
1439     PERL_ASYNC_CHECK();
1440
1441 SysRet
1442 sigprocmask(how, sigset, oldsigset = 0)
1443         int                     how
1444         POSIX::SigSet           sigset = NO_INIT
1445         POSIX::SigSet           oldsigset = NO_INIT
1446 INIT:
1447         if (! SvOK(ST(1))) {
1448             sigset = NULL;
1449         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
1450             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
1451         } else {
1452             croak("sigset is not of type POSIX::SigSet");
1453         }
1454
1455         if (items < 3 || ! SvOK(ST(2))) {
1456             oldsigset = NULL;
1457         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
1458             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
1459         } else {
1460             croak("oldsigset is not of type POSIX::SigSet");
1461         }
1462
1463 void
1464 _exit(status)
1465         int             status
1466
1467 SysRet
1468 dup2(fd1, fd2)
1469         int             fd1
1470         int             fd2
1471     CODE:
1472 #ifdef WIN32
1473         /* RT #98912 - More Microsoft muppetry - failing to actually implemented
1474            the well known documented POSIX behaviour for a POSIX API.
1475            http://msdn.microsoft.com/en-us/library/8syseb29.aspx   */
1476         RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
1477 #else
1478         RETVAL = dup2(fd1, fd2);
1479 #endif
1480     OUTPUT:
1481         RETVAL
1482
1483 SV *
1484 lseek(fd, offset, whence)
1485         int             fd
1486         Off_t           offset
1487         int             whence
1488     CODE:
1489         Off_t pos = PerlLIO_lseek(fd, offset, whence);
1490         RETVAL = sizeof(Off_t) > sizeof(IV)
1491                  ? newSVnv((NV)pos) : newSViv((IV)pos);
1492     OUTPUT:
1493         RETVAL
1494
1495 void
1496 nice(incr)
1497         int             incr
1498     PPCODE:
1499         errno = 0;
1500         if ((incr = nice(incr)) != -1 || errno == 0) {
1501             if (incr == 0)
1502                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
1503             else
1504                 XPUSHs(sv_2mortal(newSViv(incr)));
1505         }
1506
1507 void
1508 pipe()
1509     PPCODE:
1510         int fds[2];
1511         if (pipe(fds) != -1) {
1512             EXTEND(SP,2);
1513             PUSHs(sv_2mortal(newSViv(fds[0])));
1514             PUSHs(sv_2mortal(newSViv(fds[1])));
1515         }
1516
1517 SysRet
1518 read(fd, buffer, nbytes)
1519     PREINIT:
1520         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
1521     INPUT:
1522         int             fd
1523         size_t          nbytes
1524         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
1525     CLEANUP:
1526         if (RETVAL >= 0) {
1527             SvCUR_set(sv_buffer, RETVAL);
1528             SvPOK_only(sv_buffer);
1529             *SvEND(sv_buffer) = '\0';
1530             SvTAINTED_on(sv_buffer);
1531         }
1532
1533 SysRet
1534 setpgid(pid, pgid)
1535         pid_t           pid
1536         pid_t           pgid
1537
1538 pid_t
1539 setsid()
1540
1541 pid_t
1542 tcgetpgrp(fd)
1543         int             fd
1544
1545 SysRet
1546 tcsetpgrp(fd, pgrp_id)
1547         int             fd
1548         pid_t           pgrp_id
1549
1550 void
1551 uname()
1552     PPCODE:
1553 #ifdef HAS_UNAME
1554         struct utsname buf;
1555         if (uname(&buf) >= 0) {
1556             EXTEND(SP, 5);
1557             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
1558             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
1559             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
1560             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
1561             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
1562         }
1563 #else
1564         uname((char *) 0); /* A stub to call not_here(). */
1565 #endif
1566
1567 SysRet
1568 write(fd, buffer, nbytes)
1569         int             fd
1570         char *          buffer
1571         size_t          nbytes
1572
1573 SV *
1574 tmpnam()
1575     PREINIT:
1576         STRLEN i;
1577         int len;
1578     CODE:
1579         RETVAL = newSVpvn("", 0);
1580         SvGROW(RETVAL, L_tmpnam);
1581         len = strlen(tmpnam(SvPV(RETVAL, i)));
1582         SvCUR_set(RETVAL, len);
1583     OUTPUT:
1584         RETVAL
1585
1586 void
1587 abort()
1588
1589 int
1590 mblen(s, n)
1591         char *          s
1592         size_t          n
1593
1594 size_t
1595 mbstowcs(s, pwcs, n)
1596         wchar_t *       s
1597         char *          pwcs
1598         size_t          n
1599
1600 int
1601 mbtowc(pwc, s, n)
1602         wchar_t *       pwc
1603         char *          s
1604         size_t          n
1605
1606 int
1607 wcstombs(s, pwcs, n)
1608         char *          s
1609         wchar_t *       pwcs
1610         size_t          n
1611
1612 int
1613 wctomb(s, wchar)
1614         char *          s
1615         wchar_t         wchar
1616
1617 int
1618 strcoll(s1, s2)
1619         char *          s1
1620         char *          s2
1621
1622 void
1623 strtod(str)
1624         char *          str
1625     PREINIT:
1626         double num;
1627         char *unparsed;
1628     PPCODE:
1629         SET_NUMERIC_LOCAL();
1630         num = strtod(str, &unparsed);
1631         PUSHs(sv_2mortal(newSVnv(num)));
1632         if (GIMME == G_ARRAY) {
1633             EXTEND(SP, 1);
1634             if (unparsed)
1635                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1636             else
1637                 PUSHs(&PL_sv_undef);
1638         }
1639
1640 void
1641 strtol(str, base = 0)
1642         char *          str
1643         int             base
1644     PREINIT:
1645         long num;
1646         char *unparsed;
1647     PPCODE:
1648         num = strtol(str, &unparsed, base);
1649 #if IVSIZE <= LONGSIZE
1650         if (num < IV_MIN || num > IV_MAX)
1651             PUSHs(sv_2mortal(newSVnv((double)num)));
1652         else
1653 #endif
1654             PUSHs(sv_2mortal(newSViv((IV)num)));
1655         if (GIMME == G_ARRAY) {
1656             EXTEND(SP, 1);
1657             if (unparsed)
1658                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1659             else
1660                 PUSHs(&PL_sv_undef);
1661         }
1662
1663 void
1664 strtoul(str, base = 0)
1665         const char *    str
1666         int             base
1667     PREINIT:
1668         unsigned long num;
1669         char *unparsed;
1670     PPCODE:
1671         num = strtoul(str, &unparsed, base);
1672 #if IVSIZE <= LONGSIZE
1673         if (num > IV_MAX)
1674             PUSHs(sv_2mortal(newSVnv((double)num)));
1675         else
1676 #endif
1677             PUSHs(sv_2mortal(newSViv((IV)num)));
1678         if (GIMME == G_ARRAY) {
1679             EXTEND(SP, 1);
1680             if (unparsed)
1681                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1682             else
1683                 PUSHs(&PL_sv_undef);
1684         }
1685
1686 void
1687 strxfrm(src)
1688         SV *            src
1689     CODE:
1690         {
1691           STRLEN srclen;
1692           STRLEN dstlen;
1693           char *p = SvPV(src,srclen);
1694           srclen++;
1695           ST(0) = sv_2mortal(newSV(srclen*4+1));
1696           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
1697           if (dstlen > srclen) {
1698               dstlen++;
1699               SvGROW(ST(0), dstlen);
1700               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
1701               dstlen--;
1702           }
1703           SvCUR_set(ST(0), dstlen);
1704             SvPOK_only(ST(0));
1705         }
1706
1707 SysRet
1708 mkfifo(filename, mode)
1709         char *          filename
1710         Mode_t          mode
1711     ALIAS:
1712         access = 1
1713     CODE:
1714         if(ix) {
1715             RETVAL = access(filename, mode);
1716         } else {
1717             TAINT_PROPER("mkfifo");
1718             RETVAL = mkfifo(filename, mode);
1719         }
1720     OUTPUT:
1721         RETVAL
1722
1723 SysRet
1724 tcdrain(fd)
1725         int             fd
1726     ALIAS:
1727         close = 1
1728         dup = 2
1729     CODE:
1730         RETVAL = ix == 1 ? close(fd)
1731             : (ix < 1 ? tcdrain(fd) : dup(fd));
1732     OUTPUT:
1733         RETVAL
1734
1735
1736 SysRet
1737 tcflow(fd, action)
1738         int             fd
1739         int             action
1740     ALIAS:
1741         tcflush = 1
1742         tcsendbreak = 2
1743     CODE:
1744         RETVAL = ix == 1 ? tcflush(fd, action)
1745             : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
1746     OUTPUT:
1747         RETVAL
1748
1749 void
1750 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1751         int             sec
1752         int             min
1753         int             hour
1754         int             mday
1755         int             mon
1756         int             year
1757         int             wday
1758         int             yday
1759         int             isdst
1760     ALIAS:
1761         mktime = 1
1762     PPCODE:
1763         {
1764             dXSTARG;
1765             struct tm mytm;
1766             init_tm(&mytm);     /* XXX workaround - see init_tm() above */
1767             mytm.tm_sec = sec;
1768             mytm.tm_min = min;
1769             mytm.tm_hour = hour;
1770             mytm.tm_mday = mday;
1771             mytm.tm_mon = mon;
1772             mytm.tm_year = year;
1773             mytm.tm_wday = wday;
1774             mytm.tm_yday = yday;
1775             mytm.tm_isdst = isdst;
1776             if (ix) {
1777                 const long result = mktime(&mytm);
1778                 if (result == -1)
1779                     SvOK_off(TARG);
1780                 else if (result == 0)
1781                     sv_setpvn(TARG, "0 but true", 10);
1782                 else
1783                     sv_setiv(TARG, (IV)result);
1784             } else {
1785                 sv_setpv(TARG, asctime(&mytm));
1786             }
1787             ST(0) = TARG;
1788             XSRETURN(1);
1789         }
1790
1791 long
1792 clock()
1793
1794 char *
1795 ctime(time)
1796         Time_t          &time
1797
1798 void
1799 times()
1800         PPCODE:
1801         struct tms tms;
1802         clock_t realtime;
1803         realtime = times( &tms );
1804         EXTEND(SP,5);
1805         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
1806         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
1807         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
1808         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
1809         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
1810
1811 double
1812 difftime(time1, time2)
1813         Time_t          time1
1814         Time_t          time2
1815
1816 #XXX: if $xsubpp::WantOptimize is always the default
1817 #     sv_setpv(TARG, ...) could be used rather than
1818 #     ST(0) = sv_2mortal(newSVpv(...))
1819 void
1820 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
1821         SV *            fmt
1822         int             sec
1823         int             min
1824         int             hour
1825         int             mday
1826         int             mon
1827         int             year
1828         int             wday
1829         int             yday
1830         int             isdst
1831     CODE:
1832         {
1833             char *buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
1834             if (buf) {
1835                 SV *const sv = sv_newmortal();
1836                 sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL);
1837                 if (SvUTF8(fmt)) {
1838                     SvUTF8_on(sv);
1839                 }
1840                 ST(0) = sv;
1841             }
1842         }
1843
1844 void
1845 tzset()
1846   PPCODE:
1847     my_tzset(aTHX);
1848
1849 void
1850 tzname()
1851     PPCODE:
1852         EXTEND(SP,2);
1853         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
1854         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
1855
1856 char *
1857 ctermid(s = 0)
1858         char *          s = 0;
1859     CODE:
1860 #ifdef HAS_CTERMID_R
1861         s = (char *) safemalloc((size_t) L_ctermid);
1862 #endif
1863         RETVAL = ctermid(s);
1864     OUTPUT:
1865         RETVAL
1866     CLEANUP:
1867 #ifdef HAS_CTERMID_R
1868         Safefree(s);
1869 #endif
1870
1871 char *
1872 cuserid(s = 0)
1873         char *          s = 0;
1874     CODE:
1875 #ifdef HAS_CUSERID
1876   RETVAL = cuserid(s);
1877 #else
1878   RETVAL = 0;
1879   not_here("cuserid");
1880 #endif
1881     OUTPUT:
1882   RETVAL
1883
1884 SysRetLong
1885 fpathconf(fd, name)
1886         int             fd
1887         int             name
1888
1889 SysRetLong
1890 pathconf(filename, name)
1891         char *          filename
1892         int             name
1893
1894 SysRet
1895 pause()
1896     CLEANUP:
1897     PERL_ASYNC_CHECK();
1898
1899 unsigned int
1900 sleep(seconds)
1901         unsigned int    seconds
1902     CODE:
1903         RETVAL = PerlProc_sleep(seconds);
1904     OUTPUT:
1905         RETVAL
1906
1907 SysRet
1908 setgid(gid)
1909         Gid_t           gid
1910     CLEANUP:
1911 #ifndef WIN32
1912         if (RETVAL >= 0) {
1913             PL_gid  = getgid();
1914             PL_egid = getegid();
1915         }
1916 #endif
1917
1918 SysRet
1919 setuid(uid)
1920         Uid_t           uid
1921     CLEANUP:
1922 #ifndef WIN32
1923         if (RETVAL >= 0) {
1924             PL_uid  = getuid();
1925             PL_euid = geteuid();
1926         }
1927 #endif
1928
1929 SysRetLong
1930 sysconf(name)
1931         int             name
1932
1933 char *
1934 ttyname(fd)
1935         int             fd
1936
1937 void
1938 getcwd()
1939     PPCODE:
1940       {
1941         dXSTARG;
1942         getcwd_sv(TARG);
1943         XSprePUSH; PUSHTARG;
1944       }
1945
1946 SysRet
1947 lchown(uid, gid, path)
1948        Uid_t           uid
1949        Gid_t           gid
1950        char *          path
1951     CODE:
1952 #ifdef HAS_LCHOWN
1953        /* yes, the order of arguments is different,
1954         * but consistent with CORE::chown() */
1955        RETVAL = lchown(path, uid, gid);
1956 #else
1957        RETVAL = not_here("lchown");
1958 #endif
1959     OUTPUT:
1960        RETVAL