This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eliminate an unused variable
[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     if (items != 1)
708        croak_xs_usage(cv,  "charstring");
709
710     {
711         dXSTARG;
712         STRLEN  len;
713         int     RETVAL;
714         unsigned char *s = (unsigned char *) SvPV(ST(0), len);
715         unsigned char *e = s + len;
716         isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
717
718         for (RETVAL = 1; RETVAL && s < e; s++)
719             if (!isfunc(*s))
720                 RETVAL = 0;
721         XSprePUSH;
722         PUSHi((IV)RETVAL);
723     }
724     XSRETURN(1);
725 }
726
727 MODULE = POSIX          PACKAGE = POSIX
728
729 BOOT:
730 {
731     CV *cv;
732     const char *file = __FILE__;
733
734     /* Ensure we get the function, not a macro implementation. Like the C89
735        standard says we can...  */
736 #undef isalnum
737     cv = newXS("POSIX::isalnum", is_common, file);
738     XSANY.any_dptr = (any_dptr_t) &isalnum;
739 #undef isalpha
740     cv = newXS("POSIX::isalpha", is_common, file);
741     XSANY.any_dptr = (any_dptr_t) &isalpha;
742 #undef iscntrl
743     cv = newXS("POSIX::iscntrl", is_common, file);
744     XSANY.any_dptr = (any_dptr_t) &iscntrl;
745 #undef isdigit
746     cv = newXS("POSIX::isdigit", is_common, file);
747     XSANY.any_dptr = (any_dptr_t) &isdigit;
748 #undef isgraph
749     cv = newXS("POSIX::isgraph", is_common, file);
750     XSANY.any_dptr = (any_dptr_t) &isgraph;
751 #undef islower
752     cv = newXS("POSIX::islower", is_common, file);
753     XSANY.any_dptr = (any_dptr_t) &islower;
754 #undef isprint
755     cv = newXS("POSIX::isprint", is_common, file);
756     XSANY.any_dptr = (any_dptr_t) &isprint;
757 #undef ispunct
758     cv = newXS("POSIX::ispunct", is_common, file);
759     XSANY.any_dptr = (any_dptr_t) &ispunct;
760 #undef isspace
761     cv = newXS("POSIX::isspace", is_common, file);
762     XSANY.any_dptr = (any_dptr_t) &isspace;
763 #undef isupper
764     cv = newXS("POSIX::isupper", is_common, file);
765     XSANY.any_dptr = (any_dptr_t) &isupper;
766 #undef isxdigit
767     cv = newXS("POSIX::isxdigit", is_common, file);
768     XSANY.any_dptr = (any_dptr_t) &isxdigit;
769 }
770
771 MODULE = SigSet         PACKAGE = POSIX::SigSet         PREFIX = sig
772
773 void
774 new(packname = "POSIX::SigSet", ...)
775     const char *        packname
776     CODE:
777         {
778             int i;
779             sigset_t *const s
780                 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
781                                                sizeof(sigset_t),
782                                                packname);
783             sigemptyset(s);
784             for (i = 1; i < items; i++)
785                 sigaddset(s, SvIV(ST(i)));
786             XSRETURN(1);
787         }
788
789 SysRet
790 addset(sigset, sig)
791         POSIX::SigSet   sigset
792         int             sig
793    ALIAS:
794         delset = 1
795    CODE:
796         RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
797    OUTPUT:
798         RETVAL
799
800 SysRet
801 emptyset(sigset)
802         POSIX::SigSet   sigset
803    ALIAS:
804         fillset = 1
805    CODE:
806         RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
807    OUTPUT:
808         RETVAL
809
810 int
811 sigismember(sigset, sig)
812         POSIX::SigSet   sigset
813         int             sig
814
815 MODULE = Termios        PACKAGE = POSIX::Termios        PREFIX = cf
816
817 void
818 new(packname = "POSIX::Termios", ...)
819     const char *        packname
820     CODE:
821         {
822 #ifdef I_TERMIOS
823             void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
824                                             sizeof(struct termios), packname);
825             /* The previous implementation stored a pointer to an uninitialised
826                struct termios. Seems safer to initialise it, particularly as
827                this implementation exposes the struct to prying from perl-space.
828             */
829             memset(p, 0, 1 + sizeof(struct termios));
830             XSRETURN(1);
831 #else
832             not_here("termios");
833 #endif
834         }
835
836 SysRet
837 getattr(termios_ref, fd = 0)
838         POSIX::Termios  termios_ref
839         int             fd
840     CODE:
841         RETVAL = tcgetattr(fd, termios_ref);
842     OUTPUT:
843         RETVAL
844
845 # If we define TCSANOW here then both a found and not found constant sub
846 # are created causing a Constant subroutine TCSANOW redefined warning
847 #ifndef TCSANOW
848 #  define DEF_SETATTR_ACTION 0
849 #else
850 #  define DEF_SETATTR_ACTION TCSANOW
851 #endif
852 SysRet
853 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
854         POSIX::Termios  termios_ref
855         int             fd
856         int             optional_actions
857     CODE:
858         /* The second argument to the call is mandatory, but we'd like to give
859            it a useful default. 0 isn't valid on all operating systems - on
860            Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
861            values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF.  */
862         RETVAL = tcsetattr(fd, optional_actions, termios_ref);
863     OUTPUT:
864         RETVAL
865
866 speed_t
867 getispeed(termios_ref)
868         POSIX::Termios  termios_ref
869     ALIAS:
870         getospeed = 1
871     CODE:
872         RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
873     OUTPUT:
874         RETVAL
875
876 tcflag_t
877 getiflag(termios_ref)
878         POSIX::Termios  termios_ref
879     ALIAS:
880         getoflag = 1
881         getcflag = 2
882         getlflag = 3
883     CODE:
884 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
885         switch(ix) {
886         case 0:
887             RETVAL = termios_ref->c_iflag;
888             break;
889         case 1:
890             RETVAL = termios_ref->c_oflag;
891             break;
892         case 2:
893             RETVAL = termios_ref->c_cflag;
894             break;
895         case 3:
896             RETVAL = termios_ref->c_lflag;
897             break;
898         }
899 #else
900         not_here(GvNAME(CvGV(cv)));
901         RETVAL = 0;
902 #endif
903     OUTPUT:
904         RETVAL
905
906 cc_t
907 getcc(termios_ref, ccix)
908         POSIX::Termios  termios_ref
909         unsigned int    ccix
910     CODE:
911 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
912         if (ccix >= NCCS)
913             croak("Bad getcc subscript");
914         RETVAL = termios_ref->c_cc[ccix];
915 #else
916      not_here("getcc");
917      RETVAL = 0;
918 #endif
919     OUTPUT:
920         RETVAL
921
922 SysRet
923 setispeed(termios_ref, speed)
924         POSIX::Termios  termios_ref
925         speed_t         speed
926     ALIAS:
927         setospeed = 1
928     CODE:
929         RETVAL = ix
930             ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
931     OUTPUT:
932         RETVAL
933
934 void
935 setiflag(termios_ref, flag)
936         POSIX::Termios  termios_ref
937         tcflag_t        flag
938     ALIAS:
939         setoflag = 1
940         setcflag = 2
941         setlflag = 3
942     CODE:
943 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
944         switch(ix) {
945         case 0:
946             termios_ref->c_iflag = flag;
947             break;
948         case 1:
949             termios_ref->c_oflag = flag;
950             break;
951         case 2:
952             termios_ref->c_cflag = flag;
953             break;
954         case 3:
955             termios_ref->c_lflag = flag;
956             break;
957         }
958 #else
959         not_here(GvNAME(CvGV(cv)));
960 #endif
961
962 void
963 setcc(termios_ref, ccix, cc)
964         POSIX::Termios  termios_ref
965         unsigned int    ccix
966         cc_t            cc
967     CODE:
968 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
969         if (ccix >= NCCS)
970             croak("Bad setcc subscript");
971         termios_ref->c_cc[ccix] = cc;
972 #else
973             not_here("setcc");
974 #endif
975
976
977 MODULE = POSIX          PACKAGE = POSIX
978
979 INCLUDE: const-xs.inc
980
981 int
982 WEXITSTATUS(status)
983         int status
984     ALIAS:
985         POSIX::WIFEXITED = 1
986         POSIX::WIFSIGNALED = 2
987         POSIX::WIFSTOPPED = 3
988         POSIX::WSTOPSIG = 4
989         POSIX::WTERMSIG = 5
990     CODE:
991 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
992       || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
993         RETVAL = 0; /* Silence compilers that notice this, but don't realise
994                        that not_here() can't return.  */
995 #endif
996         switch(ix) {
997         case 0:
998 #ifdef WEXITSTATUS
999             RETVAL = WEXITSTATUS(WMUNGE(status));
1000 #else
1001             not_here("WEXITSTATUS");
1002 #endif
1003             break;
1004         case 1:
1005 #ifdef WIFEXITED
1006             RETVAL = WIFEXITED(WMUNGE(status));
1007 #else
1008             not_here("WIFEXITED");
1009 #endif
1010             break;
1011         case 2:
1012 #ifdef WIFSIGNALED
1013             RETVAL = WIFSIGNALED(WMUNGE(status));
1014 #else
1015             not_here("WIFSIGNALED");
1016 #endif
1017             break;
1018         case 3:
1019 #ifdef WIFSTOPPED
1020             RETVAL = WIFSTOPPED(WMUNGE(status));
1021 #else
1022             not_here("WIFSTOPPED");
1023 #endif
1024             break;
1025         case 4:
1026 #ifdef WSTOPSIG
1027             RETVAL = WSTOPSIG(WMUNGE(status));
1028 #else
1029             not_here("WSTOPSIG");
1030 #endif
1031             break;
1032         case 5:
1033 #ifdef WTERMSIG
1034             RETVAL = WTERMSIG(WMUNGE(status));
1035 #else
1036             not_here("WTERMSIG");
1037 #endif
1038             break;
1039         default:
1040             Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix);
1041         }
1042     OUTPUT:
1043         RETVAL
1044
1045 SysRet
1046 open(filename, flags = O_RDONLY, mode = 0666)
1047         char *          filename
1048         int             flags
1049         Mode_t          mode
1050     CODE:
1051         if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
1052             TAINT_PROPER("open");
1053         RETVAL = open(filename, flags, mode);
1054     OUTPUT:
1055         RETVAL
1056
1057
1058 HV *
1059 localeconv()
1060     CODE:
1061 #ifdef HAS_LOCALECONV
1062         struct lconv *lcbuf;
1063         RETVAL = newHV();
1064         sv_2mortal((SV*)RETVAL);
1065         if ((lcbuf = localeconv())) {
1066             const struct lconv_offset *strings = lconv_strings;
1067             const struct lconv_offset *integers = lconv_integers;
1068             const char *ptr = (const char *) lcbuf;
1069
1070             do {
1071                 const char *value = *((const char **)(ptr + strings->offset));
1072
1073                 if (value && *value)
1074                     (void) hv_store(RETVAL, strings->name, strlen(strings->name),
1075                                     newSVpv(value, 0), 0);
1076             } while ((++strings)->name);
1077
1078             do {
1079                 const char value = *((const char *)(ptr + integers->offset));
1080
1081                 if (value != CHAR_MAX)
1082                     (void) hv_store(RETVAL, integers->name,
1083                                     strlen(integers->name), newSViv(value), 0);
1084             } while ((++integers)->name);
1085         }
1086 #else
1087         localeconv(); /* A stub to call not_here(). */
1088 #endif
1089     OUTPUT:
1090         RETVAL
1091
1092 char *
1093 setlocale(category, locale = 0)
1094         int             category
1095         char *          locale
1096     PREINIT:
1097         char *          retval;
1098     CODE:
1099         retval = setlocale(category, locale);
1100         if (retval) {
1101             /* Save retval since subsequent setlocale() calls
1102              * may overwrite it. */
1103             RETVAL = savepv(retval);
1104 #ifdef USE_LOCALE_CTYPE
1105             if (category == LC_CTYPE
1106 #ifdef LC_ALL
1107                 || category == LC_ALL
1108 #endif
1109                 )
1110             {
1111                 char *newctype;
1112 #ifdef LC_ALL
1113                 if (category == LC_ALL)
1114                     newctype = setlocale(LC_CTYPE, NULL);
1115                 else
1116 #endif
1117                     newctype = RETVAL;
1118                 new_ctype(newctype);
1119             }
1120 #endif /* USE_LOCALE_CTYPE */
1121 #ifdef USE_LOCALE_COLLATE
1122             if (category == LC_COLLATE
1123 #ifdef LC_ALL
1124                 || category == LC_ALL
1125 #endif
1126                 )
1127             {
1128                 char *newcoll;
1129 #ifdef LC_ALL
1130                 if (category == LC_ALL)
1131                     newcoll = setlocale(LC_COLLATE, NULL);
1132                 else
1133 #endif
1134                     newcoll = RETVAL;
1135                 new_collate(newcoll);
1136             }
1137 #endif /* USE_LOCALE_COLLATE */
1138 #ifdef USE_LOCALE_NUMERIC
1139             if (category == LC_NUMERIC
1140 #ifdef LC_ALL
1141                 || category == LC_ALL
1142 #endif
1143                 )
1144             {
1145                 char *newnum;
1146 #ifdef LC_ALL
1147                 if (category == LC_ALL)
1148                     newnum = setlocale(LC_NUMERIC, NULL);
1149                 else
1150 #endif
1151                     newnum = RETVAL;
1152                 new_numeric(newnum);
1153             }
1154 #endif /* USE_LOCALE_NUMERIC */
1155         }
1156         else
1157             RETVAL = NULL;
1158     OUTPUT:
1159         RETVAL
1160     CLEANUP:
1161         if (RETVAL)
1162             Safefree(RETVAL);
1163
1164 NV
1165 acos(x)
1166         NV              x
1167     ALIAS:
1168         asin = 1
1169         atan = 2
1170         ceil = 3
1171         cosh = 4
1172         floor = 5
1173         log10 = 6
1174         sinh = 7
1175         tan = 8
1176         tanh = 9
1177     CODE:
1178         switch (ix) {
1179         case 0:
1180             RETVAL = acos(x);
1181             break;
1182         case 1:
1183             RETVAL = asin(x);
1184             break;
1185         case 2:
1186             RETVAL = atan(x);
1187             break;
1188         case 3:
1189             RETVAL = ceil(x);
1190             break;
1191         case 4:
1192             RETVAL = cosh(x);
1193             break;
1194         case 5:
1195             RETVAL = floor(x);
1196             break;
1197         case 6:
1198             RETVAL = log10(x);
1199             break;
1200         case 7:
1201             RETVAL = sinh(x);
1202             break;
1203         case 8:
1204             RETVAL = tan(x);
1205             break;
1206         default:
1207             RETVAL = tanh(x);
1208         }
1209     OUTPUT:
1210         RETVAL
1211
1212 NV
1213 fmod(x,y)
1214         NV              x
1215         NV              y
1216
1217 void
1218 frexp(x)
1219         NV              x
1220     PPCODE:
1221         int expvar;
1222         /* (We already know stack is long enough.) */
1223         PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
1224         PUSHs(sv_2mortal(newSViv(expvar)));
1225
1226 NV
1227 ldexp(x,exp)
1228         NV              x
1229         int             exp
1230
1231 void
1232 modf(x)
1233         NV              x
1234     PPCODE:
1235         NV intvar;
1236         /* (We already know stack is long enough.) */
1237         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
1238         PUSHs(sv_2mortal(newSVnv(intvar)));
1239
1240 SysRet
1241 sigaction(sig, optaction, oldaction = 0)
1242         int                     sig
1243         SV *                    optaction
1244         POSIX::SigAction        oldaction
1245     CODE:
1246 #if defined(WIN32) || defined(NETWARE)
1247         RETVAL = not_here("sigaction");
1248 #else
1249 # This code is really grody because we're trying to make the signal
1250 # interface look beautiful, which is hard.
1251
1252         {
1253             dVAR;
1254             POSIX__SigAction action;
1255             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
1256             struct sigaction act;
1257             struct sigaction oact;
1258             sigset_t sset;
1259             SV *osset_sv;
1260             sigset_t osset;
1261             POSIX__SigSet sigset;
1262             SV** svp;
1263             SV** sigsvp;
1264
1265             if (sig < 0) {
1266                 croak("Negative signals are not allowed");
1267             }
1268
1269             if (sig == 0 && SvPOK(ST(0))) {
1270                 const char *s = SvPVX_const(ST(0));
1271                 int i = whichsig(s);
1272
1273                 if (i < 0 && memEQ(s, "SIG", 3))
1274                     i = whichsig(s + 3);
1275                 if (i < 0) {
1276                     if (ckWARN(WARN_SIGNAL))
1277                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1278                                     "No such signal: SIG%s", s);
1279                     XSRETURN_UNDEF;
1280                 }
1281                 else
1282                     sig = i;
1283             }
1284 #ifdef NSIG
1285             if (sig > NSIG) { /* NSIG - 1 is still okay. */
1286                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1287                             "No such signal: %d", sig);
1288                 XSRETURN_UNDEF;
1289             }
1290 #endif
1291             sigsvp = hv_fetch(GvHVn(siggv),
1292                               PL_sig_name[sig],
1293                               strlen(PL_sig_name[sig]),
1294                               TRUE);
1295
1296             /* Check optaction and set action */
1297             if(SvTRUE(optaction)) {
1298                 if(sv_isa(optaction, "POSIX::SigAction"))
1299                         action = (HV*)SvRV(optaction);
1300                 else
1301                         croak("action is not of type POSIX::SigAction");
1302             }
1303             else {
1304                 action=0;
1305             }
1306
1307             /* sigaction() is supposed to look atomic. In particular, any
1308              * signal handler invoked during a sigaction() call should
1309              * see either the old or the new disposition, and not something
1310              * in between. We use sigprocmask() to make it so.
1311              */
1312             sigfillset(&sset);
1313             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
1314             if(RETVAL == -1)
1315                XSRETURN_UNDEF;
1316             ENTER;
1317             /* Restore signal mask no matter how we exit this block. */
1318             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
1319             SAVEFREESV( osset_sv );
1320             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1321
1322             RETVAL=-1; /* In case both oldaction and action are 0. */
1323
1324             /* Remember old disposition if desired. */
1325             if (oldaction) {
1326                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1327                 if(!svp)
1328                     croak("Can't supply an oldaction without a HANDLER");
1329                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
1330                         sv_setsv(*svp, *sigsvp);
1331                 }
1332                 else {
1333                         sv_setpvs(*svp, "DEFAULT");
1334                 }
1335                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
1336                 if(RETVAL == -1) {
1337                    LEAVE;
1338                    XSRETURN_UNDEF;
1339                 }
1340                 /* Get back the mask. */
1341                 svp = hv_fetchs(oldaction, "MASK", TRUE);
1342                 if (sv_isa(*svp, "POSIX::SigSet")) {
1343                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1344                 }
1345                 else {
1346                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
1347                                                           sizeof(sigset_t),
1348                                                           "POSIX::SigSet");
1349                 }
1350                 *sigset = oact.sa_mask;
1351
1352                 /* Get back the flags. */
1353                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1354                 sv_setiv(*svp, oact.sa_flags);
1355
1356                 /* Get back whether the old handler used safe signals. */
1357                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
1358                 sv_setiv(*svp,
1359                 /* compare incompatible pointers by casting to integer */
1360                     PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
1361             }
1362
1363             if (action) {
1364                 /* Safe signals use "csighandler", which vectors through the
1365                    PL_sighandlerp pointer when it's safe to do so.
1366                    (BTW, "csighandler" is very different from "sighandler".) */
1367                 svp = hv_fetchs(action, "SAFE", FALSE);
1368                 act.sa_handler =
1369                         DPTR2FPTR(
1370                             void (*)(int),
1371                             (*svp && SvTRUE(*svp))
1372                                 ? PL_csighandlerp : PL_sighandlerp
1373                         );
1374
1375                 /* Vector new Perl handler through %SIG.
1376                    (The core signal handlers read %SIG to dispatch.) */
1377                 svp = hv_fetchs(action, "HANDLER", FALSE);
1378                 if (!svp)
1379                     croak("Can't supply an action without a HANDLER");
1380                 sv_setsv(*sigsvp, *svp);
1381
1382                 /* This call actually calls sigaction() with almost the
1383                    right settings, including appropriate interpretation
1384                    of DEFAULT and IGNORE.  However, why are we doing
1385                    this when we're about to do it again just below?  XXX */
1386                 SvSETMAGIC(*sigsvp);
1387
1388                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1389                 if(SvPOK(*svp)) {
1390                         const char *s=SvPVX_const(*svp);
1391                         if(strEQ(s,"IGNORE")) {
1392                                 act.sa_handler = SIG_IGN;
1393                         }
1394                         else if(strEQ(s,"DEFAULT")) {
1395                                 act.sa_handler = SIG_DFL;
1396                         }
1397                 }
1398
1399                 /* Set up any desired mask. */
1400                 svp = hv_fetchs(action, "MASK", FALSE);
1401                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
1402                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1403                     act.sa_mask = *sigset;
1404                 }
1405                 else
1406                     sigemptyset(& act.sa_mask);
1407
1408                 /* Set up any desired flags. */
1409                 svp = hv_fetchs(action, "FLAGS", FALSE);
1410                 act.sa_flags = svp ? SvIV(*svp) : 0;
1411
1412                 /* Don't worry about cleaning up *sigsvp if this fails,
1413                  * because that means we tried to disposition a
1414                  * nonblockable signal, in which case *sigsvp is
1415                  * essentially meaningless anyway.
1416                  */
1417                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
1418                 if(RETVAL == -1) {
1419                     LEAVE;
1420                     XSRETURN_UNDEF;
1421                 }
1422             }
1423
1424             LEAVE;
1425         }
1426 #endif
1427     OUTPUT:
1428         RETVAL
1429
1430 SysRet
1431 sigpending(sigset)
1432         POSIX::SigSet           sigset
1433     ALIAS:
1434         sigsuspend = 1
1435     CODE:
1436         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
1437     OUTPUT:
1438         RETVAL
1439     CLEANUP:
1440     PERL_ASYNC_CHECK();
1441
1442 SysRet
1443 sigprocmask(how, sigset, oldsigset = 0)
1444         int                     how
1445         POSIX::SigSet           sigset = NO_INIT
1446         POSIX::SigSet           oldsigset = NO_INIT
1447 INIT:
1448         if (! SvOK(ST(1))) {
1449             sigset = NULL;
1450         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
1451             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
1452         } else {
1453             croak("sigset is not of type POSIX::SigSet");
1454         }
1455
1456         if (items < 3 || ! SvOK(ST(2))) {
1457             oldsigset = NULL;
1458         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
1459             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
1460         } else {
1461             croak("oldsigset is not of type POSIX::SigSet");
1462         }
1463
1464 void
1465 _exit(status)
1466         int             status
1467
1468 SysRet
1469 dup2(fd1, fd2)
1470         int             fd1
1471         int             fd2
1472     CODE:
1473 #ifdef WIN32
1474         /* RT #98912 - More Microsoft muppetry - failing to actually implemented
1475            the well known documented POSIX behaviour for a POSIX API.
1476            http://msdn.microsoft.com/en-us/library/8syseb29.aspx   */
1477         RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
1478 #else
1479         RETVAL = dup2(fd1, fd2);
1480 #endif
1481     OUTPUT:
1482         RETVAL
1483
1484 SV *
1485 lseek(fd, offset, whence)
1486         int             fd
1487         Off_t           offset
1488         int             whence
1489     CODE:
1490         Off_t pos = PerlLIO_lseek(fd, offset, whence);
1491         RETVAL = sizeof(Off_t) > sizeof(IV)
1492                  ? newSVnv((NV)pos) : newSViv((IV)pos);
1493     OUTPUT:
1494         RETVAL
1495
1496 void
1497 nice(incr)
1498         int             incr
1499     PPCODE:
1500         errno = 0;
1501         if ((incr = nice(incr)) != -1 || errno == 0) {
1502             if (incr == 0)
1503                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
1504             else
1505                 XPUSHs(sv_2mortal(newSViv(incr)));
1506         }
1507
1508 void
1509 pipe()
1510     PPCODE:
1511         int fds[2];
1512         if (pipe(fds) != -1) {
1513             EXTEND(SP,2);
1514             PUSHs(sv_2mortal(newSViv(fds[0])));
1515             PUSHs(sv_2mortal(newSViv(fds[1])));
1516         }
1517
1518 SysRet
1519 read(fd, buffer, nbytes)
1520     PREINIT:
1521         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
1522     INPUT:
1523         int             fd
1524         size_t          nbytes
1525         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
1526     CLEANUP:
1527         if (RETVAL >= 0) {
1528             SvCUR_set(sv_buffer, RETVAL);
1529             SvPOK_only(sv_buffer);
1530             *SvEND(sv_buffer) = '\0';
1531             SvTAINTED_on(sv_buffer);
1532         }
1533
1534 SysRet
1535 setpgid(pid, pgid)
1536         pid_t           pid
1537         pid_t           pgid
1538
1539 pid_t
1540 setsid()
1541
1542 pid_t
1543 tcgetpgrp(fd)
1544         int             fd
1545
1546 SysRet
1547 tcsetpgrp(fd, pgrp_id)
1548         int             fd
1549         pid_t           pgrp_id
1550
1551 void
1552 uname()
1553     PPCODE:
1554 #ifdef HAS_UNAME
1555         struct utsname buf;
1556         if (uname(&buf) >= 0) {
1557             EXTEND(SP, 5);
1558             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
1559             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
1560             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
1561             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
1562             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
1563         }
1564 #else
1565         uname((char *) 0); /* A stub to call not_here(). */
1566 #endif
1567
1568 SysRet
1569 write(fd, buffer, nbytes)
1570         int             fd
1571         char *          buffer
1572         size_t          nbytes
1573
1574 SV *
1575 tmpnam()
1576     PREINIT:
1577         STRLEN i;
1578         int len;
1579     CODE:
1580         RETVAL = newSVpvn("", 0);
1581         SvGROW(RETVAL, L_tmpnam);
1582         len = strlen(tmpnam(SvPV(RETVAL, i)));
1583         SvCUR_set(RETVAL, len);
1584     OUTPUT:
1585         RETVAL
1586
1587 void
1588 abort()
1589
1590 int
1591 mblen(s, n)
1592         char *          s
1593         size_t          n
1594
1595 size_t
1596 mbstowcs(s, pwcs, n)
1597         wchar_t *       s
1598         char *          pwcs
1599         size_t          n
1600
1601 int
1602 mbtowc(pwc, s, n)
1603         wchar_t *       pwc
1604         char *          s
1605         size_t          n
1606
1607 int
1608 wcstombs(s, pwcs, n)
1609         char *          s
1610         wchar_t *       pwcs
1611         size_t          n
1612
1613 int
1614 wctomb(s, wchar)
1615         char *          s
1616         wchar_t         wchar
1617
1618 int
1619 strcoll(s1, s2)
1620         char *          s1
1621         char *          s2
1622
1623 void
1624 strtod(str)
1625         char *          str
1626     PREINIT:
1627         double num;
1628         char *unparsed;
1629     PPCODE:
1630         SET_NUMERIC_LOCAL();
1631         num = strtod(str, &unparsed);
1632         PUSHs(sv_2mortal(newSVnv(num)));
1633         if (GIMME == G_ARRAY) {
1634             EXTEND(SP, 1);
1635             if (unparsed)
1636                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1637             else
1638                 PUSHs(&PL_sv_undef);
1639         }
1640
1641 void
1642 strtol(str, base = 0)
1643         char *          str
1644         int             base
1645     PREINIT:
1646         long num;
1647         char *unparsed;
1648     PPCODE:
1649         num = strtol(str, &unparsed, base);
1650 #if IVSIZE <= LONGSIZE
1651         if (num < IV_MIN || num > IV_MAX)
1652             PUSHs(sv_2mortal(newSVnv((double)num)));
1653         else
1654 #endif
1655             PUSHs(sv_2mortal(newSViv((IV)num)));
1656         if (GIMME == G_ARRAY) {
1657             EXTEND(SP, 1);
1658             if (unparsed)
1659                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1660             else
1661                 PUSHs(&PL_sv_undef);
1662         }
1663
1664 void
1665 strtoul(str, base = 0)
1666         const char *    str
1667         int             base
1668     PREINIT:
1669         unsigned long num;
1670         char *unparsed;
1671     PPCODE:
1672         num = strtoul(str, &unparsed, base);
1673 #if IVSIZE <= LONGSIZE
1674         if (num > IV_MAX)
1675             PUSHs(sv_2mortal(newSVnv((double)num)));
1676         else
1677 #endif
1678             PUSHs(sv_2mortal(newSViv((IV)num)));
1679         if (GIMME == G_ARRAY) {
1680             EXTEND(SP, 1);
1681             if (unparsed)
1682                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1683             else
1684                 PUSHs(&PL_sv_undef);
1685         }
1686
1687 void
1688 strxfrm(src)
1689         SV *            src
1690     CODE:
1691         {
1692           STRLEN srclen;
1693           STRLEN dstlen;
1694           char *p = SvPV(src,srclen);
1695           srclen++;
1696           ST(0) = sv_2mortal(newSV(srclen*4+1));
1697           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
1698           if (dstlen > srclen) {
1699               dstlen++;
1700               SvGROW(ST(0), dstlen);
1701               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
1702               dstlen--;
1703           }
1704           SvCUR_set(ST(0), dstlen);
1705             SvPOK_only(ST(0));
1706         }
1707
1708 SysRet
1709 mkfifo(filename, mode)
1710         char *          filename
1711         Mode_t          mode
1712     ALIAS:
1713         access = 1
1714     CODE:
1715         if(ix) {
1716             RETVAL = access(filename, mode);
1717         } else {
1718             TAINT_PROPER("mkfifo");
1719             RETVAL = mkfifo(filename, mode);
1720         }
1721     OUTPUT:
1722         RETVAL
1723
1724 SysRet
1725 tcdrain(fd)
1726         int             fd
1727     ALIAS:
1728         close = 1
1729         dup = 2
1730     CODE:
1731         RETVAL = ix == 1 ? close(fd)
1732             : (ix < 1 ? tcdrain(fd) : dup(fd));
1733     OUTPUT:
1734         RETVAL
1735
1736
1737 SysRet
1738 tcflow(fd, action)
1739         int             fd
1740         int             action
1741     ALIAS:
1742         tcflush = 1
1743         tcsendbreak = 2
1744     CODE:
1745         RETVAL = ix == 1 ? tcflush(fd, action)
1746             : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
1747     OUTPUT:
1748         RETVAL
1749
1750 void
1751 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1752         int             sec
1753         int             min
1754         int             hour
1755         int             mday
1756         int             mon
1757         int             year
1758         int             wday
1759         int             yday
1760         int             isdst
1761     ALIAS:
1762         mktime = 1
1763     PPCODE:
1764         {
1765             dXSTARG;
1766             struct tm mytm;
1767             init_tm(&mytm);     /* XXX workaround - see init_tm() in core util.c */
1768             mytm.tm_sec = sec;
1769             mytm.tm_min = min;
1770             mytm.tm_hour = hour;
1771             mytm.tm_mday = mday;
1772             mytm.tm_mon = mon;
1773             mytm.tm_year = year;
1774             mytm.tm_wday = wday;
1775             mytm.tm_yday = yday;
1776             mytm.tm_isdst = isdst;
1777             if (ix) {
1778                 const time_t result = mktime(&mytm);
1779                 if (result == (time_t)-1)
1780                     SvOK_off(TARG);
1781                 else if (result == 0)
1782                     sv_setpvn(TARG, "0 but true", 10);
1783                 else
1784                     sv_setiv(TARG, (IV)result);
1785             } else {
1786                 sv_setpv(TARG, asctime(&mytm));
1787             }
1788             ST(0) = TARG;
1789             XSRETURN(1);
1790         }
1791
1792 long
1793 clock()
1794
1795 char *
1796 ctime(time)
1797         Time_t          &time
1798
1799 void
1800 times()
1801         PPCODE:
1802         struct tms tms;
1803         clock_t realtime;
1804         realtime = times( &tms );
1805         EXTEND(SP,5);
1806         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
1807         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
1808         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
1809         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
1810         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
1811
1812 double
1813 difftime(time1, time2)
1814         Time_t          time1
1815         Time_t          time2
1816
1817 #XXX: if $xsubpp::WantOptimize is always the default
1818 #     sv_setpv(TARG, ...) could be used rather than
1819 #     ST(0) = sv_2mortal(newSVpv(...))
1820 void
1821 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
1822         SV *            fmt
1823         int             sec
1824         int             min
1825         int             hour
1826         int             mday
1827         int             mon
1828         int             year
1829         int             wday
1830         int             yday
1831         int             isdst
1832     CODE:
1833         {
1834             char *buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
1835             if (buf) {
1836                 SV *const sv = sv_newmortal();
1837                 sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL);
1838                 if (SvUTF8(fmt)) {
1839                     SvUTF8_on(sv);
1840                 }
1841                 ST(0) = sv;
1842             }
1843         }
1844
1845 void
1846 tzset()
1847   PPCODE:
1848     my_tzset(aTHX);
1849
1850 void
1851 tzname()
1852     PPCODE:
1853         EXTEND(SP,2);
1854         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
1855         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
1856
1857 char *
1858 ctermid(s = 0)
1859         char *          s = 0;
1860     CODE:
1861 #ifdef HAS_CTERMID_R
1862         s = (char *) safemalloc((size_t) L_ctermid);
1863 #endif
1864         RETVAL = ctermid(s);
1865     OUTPUT:
1866         RETVAL
1867     CLEANUP:
1868 #ifdef HAS_CTERMID_R
1869         Safefree(s);
1870 #endif
1871
1872 char *
1873 cuserid(s = 0)
1874         char *          s = 0;
1875     CODE:
1876 #ifdef HAS_CUSERID
1877   RETVAL = cuserid(s);
1878 #else
1879   RETVAL = 0;
1880   not_here("cuserid");
1881 #endif
1882     OUTPUT:
1883   RETVAL
1884
1885 SysRetLong
1886 fpathconf(fd, name)
1887         int             fd
1888         int             name
1889
1890 SysRetLong
1891 pathconf(filename, name)
1892         char *          filename
1893         int             name
1894
1895 SysRet
1896 pause()
1897     CLEANUP:
1898     PERL_ASYNC_CHECK();
1899
1900 unsigned int
1901 sleep(seconds)
1902         unsigned int    seconds
1903     CODE:
1904         RETVAL = PerlProc_sleep(seconds);
1905     OUTPUT:
1906         RETVAL
1907
1908 SysRet
1909 setgid(gid)
1910         Gid_t           gid
1911
1912 SysRet
1913 setuid(uid)
1914         Uid_t           uid
1915
1916 SysRetLong
1917 sysconf(name)
1918         int             name
1919
1920 char *
1921 ttyname(fd)
1922         int             fd
1923
1924 void
1925 getcwd()
1926     PPCODE:
1927       {
1928         dXSTARG;
1929         getcwd_sv(TARG);
1930         XSprePUSH; PUSHTARG;
1931       }
1932
1933 SysRet
1934 lchown(uid, gid, path)
1935        Uid_t           uid
1936        Gid_t           gid
1937        char *          path
1938     CODE:
1939 #ifdef HAS_LCHOWN
1940        /* yes, the order of arguments is different,
1941         * but consistent with CORE::chown() */
1942        RETVAL = lchown(path, uid, gid);
1943 #else
1944        RETVAL = not_here("lchown");
1945 #endif
1946     OUTPUT:
1947        RETVAL