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