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