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