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