This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8b1a41b0bc0fc2285ace5fae56c22a3a28977c8b
[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
1256 NV
1257 asin(x)
1258         NV              x
1259
1260 NV
1261 atan(x)
1262         NV              x
1263
1264 NV
1265 ceil(x)
1266         NV              x
1267
1268 NV
1269 cosh(x)
1270         NV              x
1271
1272 NV
1273 floor(x)
1274         NV              x
1275
1276 NV
1277 fmod(x,y)
1278         NV              x
1279         NV              y
1280
1281 void
1282 frexp(x)
1283         NV              x
1284     PPCODE:
1285         int expvar;
1286         /* (We already know stack is long enough.) */
1287         PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
1288         PUSHs(sv_2mortal(newSViv(expvar)));
1289
1290 NV
1291 ldexp(x,exp)
1292         NV              x
1293         int             exp
1294
1295 NV
1296 log10(x)
1297         NV              x
1298
1299 void
1300 modf(x)
1301         NV              x
1302     PPCODE:
1303         NV intvar;
1304         /* (We already know stack is long enough.) */
1305         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
1306         PUSHs(sv_2mortal(newSVnv(intvar)));
1307
1308 NV
1309 sinh(x)
1310         NV              x
1311
1312 NV
1313 tan(x)
1314         NV              x
1315
1316 NV
1317 tanh(x)
1318         NV              x
1319
1320 SysRet
1321 sigaction(sig, optaction, oldaction = 0)
1322         int                     sig
1323         SV *                    optaction
1324         POSIX::SigAction        oldaction
1325     CODE:
1326 #if defined(WIN32) || defined(NETWARE)
1327         RETVAL = not_here("sigaction");
1328 #else
1329 # This code is really grody because we're trying to make the signal
1330 # interface look beautiful, which is hard.
1331
1332         {
1333             dVAR;
1334             POSIX__SigAction action;
1335             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
1336             struct sigaction act;
1337             struct sigaction oact;
1338             sigset_t sset;
1339             SV *osset_sv;
1340             sigset_t osset;
1341             POSIX__SigSet sigset;
1342             SV** svp;
1343             SV** sigsvp;
1344
1345             if (sig < 0) {
1346                 croak("Negative signals are not allowed");
1347             }
1348
1349             if (sig == 0 && SvPOK(ST(0))) {
1350                 const char *s = SvPVX_const(ST(0));
1351                 int i = whichsig(s);
1352
1353                 if (i < 0 && memEQ(s, "SIG", 3))
1354                     i = whichsig(s + 3);
1355                 if (i < 0) {
1356                     if (ckWARN(WARN_SIGNAL))
1357                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1358                                     "No such signal: SIG%s", s);
1359                     XSRETURN_UNDEF;
1360                 }
1361                 else
1362                     sig = i;
1363             }
1364 #ifdef NSIG
1365             if (sig > NSIG) { /* NSIG - 1 is still okay. */
1366                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1367                             "No such signal: %d", sig);
1368                 XSRETURN_UNDEF;
1369             }
1370 #endif
1371             sigsvp = hv_fetch(GvHVn(siggv),
1372                               PL_sig_name[sig],
1373                               strlen(PL_sig_name[sig]),
1374                               TRUE);
1375
1376             /* Check optaction and set action */
1377             if(SvTRUE(optaction)) {
1378                 if(sv_isa(optaction, "POSIX::SigAction"))
1379                         action = (HV*)SvRV(optaction);
1380                 else
1381                         croak("action is not of type POSIX::SigAction");
1382             }
1383             else {
1384                 action=0;
1385             }
1386
1387             /* sigaction() is supposed to look atomic. In particular, any
1388              * signal handler invoked during a sigaction() call should
1389              * see either the old or the new disposition, and not something
1390              * in between. We use sigprocmask() to make it so.
1391              */
1392             sigfillset(&sset);
1393             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
1394             if(RETVAL == -1)
1395                XSRETURN_UNDEF;
1396             ENTER;
1397             /* Restore signal mask no matter how we exit this block. */
1398             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
1399             SAVEFREESV( osset_sv );
1400             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1401
1402             RETVAL=-1; /* In case both oldaction and action are 0. */
1403
1404             /* Remember old disposition if desired. */
1405             if (oldaction) {
1406                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1407                 if(!svp)
1408                     croak("Can't supply an oldaction without a HANDLER");
1409                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
1410                         sv_setsv(*svp, *sigsvp);
1411                 }
1412                 else {
1413                         sv_setpvs(*svp, "DEFAULT");
1414                 }
1415                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
1416                 if(RETVAL == -1) {
1417                    LEAVE;
1418                    XSRETURN_UNDEF;
1419                 }
1420                 /* Get back the mask. */
1421                 svp = hv_fetchs(oldaction, "MASK", TRUE);
1422                 if (sv_isa(*svp, "POSIX::SigSet")) {
1423                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1424                 }
1425                 else {
1426                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
1427                                                           sizeof(sigset_t),
1428                                                           "POSIX::SigSet");
1429                 }
1430                 *sigset = oact.sa_mask;
1431
1432                 /* Get back the flags. */
1433                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1434                 sv_setiv(*svp, oact.sa_flags);
1435
1436                 /* Get back whether the old handler used safe signals. */
1437                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
1438                 sv_setiv(*svp,
1439                 /* compare incompatible pointers by casting to integer */
1440                     PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
1441             }
1442
1443             if (action) {
1444                 /* Safe signals use "csighandler", which vectors through the
1445                    PL_sighandlerp pointer when it's safe to do so.
1446                    (BTW, "csighandler" is very different from "sighandler".) */
1447                 svp = hv_fetchs(action, "SAFE", FALSE);
1448                 act.sa_handler =
1449                         DPTR2FPTR(
1450                             void (*)(int),
1451                             (*svp && SvTRUE(*svp))
1452                                 ? PL_csighandlerp : PL_sighandlerp
1453                         );
1454
1455                 /* Vector new Perl handler through %SIG.
1456                    (The core signal handlers read %SIG to dispatch.) */
1457                 svp = hv_fetchs(action, "HANDLER", FALSE);
1458                 if (!svp)
1459                     croak("Can't supply an action without a HANDLER");
1460                 sv_setsv(*sigsvp, *svp);
1461
1462                 /* This call actually calls sigaction() with almost the
1463                    right settings, including appropriate interpretation
1464                    of DEFAULT and IGNORE.  However, why are we doing
1465                    this when we're about to do it again just below?  XXX */
1466                 SvSETMAGIC(*sigsvp);
1467
1468                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1469                 if(SvPOK(*svp)) {
1470                         const char *s=SvPVX_const(*svp);
1471                         if(strEQ(s,"IGNORE")) {
1472                                 act.sa_handler = SIG_IGN;
1473                         }
1474                         else if(strEQ(s,"DEFAULT")) {
1475                                 act.sa_handler = SIG_DFL;
1476                         }
1477                 }
1478
1479                 /* Set up any desired mask. */
1480                 svp = hv_fetchs(action, "MASK", FALSE);
1481                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
1482                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1483                     act.sa_mask = *sigset;
1484                 }
1485                 else
1486                     sigemptyset(& act.sa_mask);
1487
1488                 /* Set up any desired flags. */
1489                 svp = hv_fetchs(action, "FLAGS", FALSE);
1490                 act.sa_flags = svp ? SvIV(*svp) : 0;
1491
1492                 /* Don't worry about cleaning up *sigsvp if this fails,
1493                  * because that means we tried to disposition a
1494                  * nonblockable signal, in which case *sigsvp is
1495                  * essentially meaningless anyway.
1496                  */
1497                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
1498                 if(RETVAL == -1) {
1499                     LEAVE;
1500                     XSRETURN_UNDEF;
1501                 }
1502             }
1503
1504             LEAVE;
1505         }
1506 #endif
1507     OUTPUT:
1508         RETVAL
1509
1510 SysRet
1511 sigpending(sigset)
1512         POSIX::SigSet           sigset
1513     ALIAS:
1514         sigsuspend = 1
1515     CODE:
1516         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
1517     OUTPUT:
1518         RETVAL
1519
1520 SysRet
1521 sigprocmask(how, sigset, oldsigset = 0)
1522         int                     how
1523         POSIX::SigSet           sigset = NO_INIT
1524         POSIX::SigSet           oldsigset = NO_INIT
1525 INIT:
1526         if (! SvOK(ST(1))) {
1527             sigset = NULL;
1528         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
1529             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
1530         } else {
1531             croak("sigset is not of type POSIX::SigSet");
1532         }
1533
1534         if (items < 3 || ! SvOK(ST(2))) {
1535             oldsigset = NULL;
1536         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
1537             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
1538         } else {
1539             croak("oldsigset is not of type POSIX::SigSet");
1540         }
1541
1542 void
1543 _exit(status)
1544         int             status
1545
1546 SysRet
1547 close(fd)
1548         int             fd
1549
1550 SysRet
1551 dup(fd)
1552         int             fd
1553
1554 SysRet
1555 dup2(fd1, fd2)
1556         int             fd1
1557         int             fd2
1558
1559 SV *
1560 lseek(fd, offset, whence)
1561         int             fd
1562         Off_t           offset
1563         int             whence
1564     CODE:
1565         Off_t pos = PerlLIO_lseek(fd, offset, whence);
1566         RETVAL = sizeof(Off_t) > sizeof(IV)
1567                  ? newSVnv((NV)pos) : newSViv((IV)pos);
1568     OUTPUT:
1569         RETVAL
1570
1571 void
1572 nice(incr)
1573         int             incr
1574     PPCODE:
1575         errno = 0;
1576         if ((incr = nice(incr)) != -1 || errno == 0) {
1577             if (incr == 0)
1578                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
1579             else
1580                 XPUSHs(sv_2mortal(newSViv(incr)));
1581         }
1582
1583 void
1584 pipe()
1585     PPCODE:
1586         int fds[2];
1587         if (pipe(fds) != -1) {
1588             EXTEND(SP,2);
1589             PUSHs(sv_2mortal(newSViv(fds[0])));
1590             PUSHs(sv_2mortal(newSViv(fds[1])));
1591         }
1592
1593 SysRet
1594 read(fd, buffer, nbytes)
1595     PREINIT:
1596         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
1597     INPUT:
1598         int             fd
1599         size_t          nbytes
1600         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
1601     CLEANUP:
1602         if (RETVAL >= 0) {
1603             SvCUR_set(sv_buffer, RETVAL);
1604             SvPOK_only(sv_buffer);
1605             *SvEND(sv_buffer) = '\0';
1606             SvTAINTED_on(sv_buffer);
1607         }
1608
1609 SysRet
1610 setpgid(pid, pgid)
1611         pid_t           pid
1612         pid_t           pgid
1613
1614 pid_t
1615 setsid()
1616
1617 pid_t
1618 tcgetpgrp(fd)
1619         int             fd
1620
1621 SysRet
1622 tcsetpgrp(fd, pgrp_id)
1623         int             fd
1624         pid_t           pgrp_id
1625
1626 void
1627 uname()
1628     PPCODE:
1629 #ifdef HAS_UNAME
1630         struct utsname buf;
1631         if (uname(&buf) >= 0) {
1632             EXTEND(SP, 5);
1633             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
1634             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
1635             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
1636             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
1637             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
1638         }
1639 #else
1640         uname((char *) 0); /* A stub to call not_here(). */
1641 #endif
1642
1643 SysRet
1644 write(fd, buffer, nbytes)
1645         int             fd
1646         char *          buffer
1647         size_t          nbytes
1648
1649 SV *
1650 tmpnam()
1651     PREINIT:
1652         STRLEN i;
1653         int len;
1654     CODE:
1655         RETVAL = newSVpvn("", 0);
1656         SvGROW(RETVAL, L_tmpnam);
1657         len = strlen(tmpnam(SvPV(RETVAL, i)));
1658         SvCUR_set(RETVAL, len);
1659     OUTPUT:
1660         RETVAL
1661
1662 void
1663 abort()
1664
1665 int
1666 mblen(s, n)
1667         char *          s
1668         size_t          n
1669
1670 size_t
1671 mbstowcs(s, pwcs, n)
1672         wchar_t *       s
1673         char *          pwcs
1674         size_t          n
1675
1676 int
1677 mbtowc(pwc, s, n)
1678         wchar_t *       pwc
1679         char *          s
1680         size_t          n
1681
1682 int
1683 wcstombs(s, pwcs, n)
1684         char *          s
1685         wchar_t *       pwcs
1686         size_t          n
1687
1688 int
1689 wctomb(s, wchar)
1690         char *          s
1691         wchar_t         wchar
1692
1693 int
1694 strcoll(s1, s2)
1695         char *          s1
1696         char *          s2
1697
1698 void
1699 strtod(str)
1700         char *          str
1701     PREINIT:
1702         double num;
1703         char *unparsed;
1704     PPCODE:
1705         SET_NUMERIC_LOCAL();
1706         num = strtod(str, &unparsed);
1707         PUSHs(sv_2mortal(newSVnv(num)));
1708         if (GIMME == G_ARRAY) {
1709             EXTEND(SP, 1);
1710             if (unparsed)
1711                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1712             else
1713                 PUSHs(&PL_sv_undef);
1714         }
1715
1716 void
1717 strtol(str, base = 0)
1718         char *          str
1719         int             base
1720     PREINIT:
1721         long num;
1722         char *unparsed;
1723     PPCODE:
1724         num = strtol(str, &unparsed, base);
1725 #if IVSIZE <= LONGSIZE
1726         if (num < IV_MIN || num > IV_MAX)
1727             PUSHs(sv_2mortal(newSVnv((double)num)));
1728         else
1729 #endif
1730             PUSHs(sv_2mortal(newSViv((IV)num)));
1731         if (GIMME == G_ARRAY) {
1732             EXTEND(SP, 1);
1733             if (unparsed)
1734                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1735             else
1736                 PUSHs(&PL_sv_undef);
1737         }
1738
1739 void
1740 strtoul(str, base = 0)
1741         const char *    str
1742         int             base
1743     PREINIT:
1744         unsigned long num;
1745         char *unparsed;
1746     PPCODE:
1747         num = strtoul(str, &unparsed, base);
1748 #if IVSIZE <= LONGSIZE
1749         if (num > IV_MAX)
1750             PUSHs(sv_2mortal(newSVnv((double)num)));
1751         else
1752 #endif
1753             PUSHs(sv_2mortal(newSViv((IV)num)));
1754         if (GIMME == G_ARRAY) {
1755             EXTEND(SP, 1);
1756             if (unparsed)
1757                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1758             else
1759                 PUSHs(&PL_sv_undef);
1760         }
1761
1762 void
1763 strxfrm(src)
1764         SV *            src
1765     CODE:
1766         {
1767           STRLEN srclen;
1768           STRLEN dstlen;
1769           char *p = SvPV(src,srclen);
1770           srclen++;
1771           ST(0) = sv_2mortal(newSV(srclen*4+1));
1772           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
1773           if (dstlen > srclen) {
1774               dstlen++;
1775               SvGROW(ST(0), dstlen);
1776               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
1777               dstlen--;
1778           }
1779           SvCUR_set(ST(0), dstlen);
1780             SvPOK_only(ST(0));
1781         }
1782
1783 SysRet
1784 mkfifo(filename, mode)
1785         char *          filename
1786         Mode_t          mode
1787     CODE:
1788         TAINT_PROPER("mkfifo");
1789         RETVAL = mkfifo(filename, mode);
1790     OUTPUT:
1791         RETVAL
1792
1793 SysRet
1794 tcdrain(fd)
1795         int             fd
1796
1797
1798 SysRet
1799 tcflow(fd, action)
1800         int             fd
1801         int             action
1802     ALIAS:
1803         tcflush = 1
1804         tcsendbreak = 2
1805     CODE:
1806         RETVAL = ix == 1 ? tcflush(fd, action)
1807             : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
1808     OUTPUT:
1809         RETVAL
1810
1811 char *
1812 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1813         int             sec
1814         int             min
1815         int             hour
1816         int             mday
1817         int             mon
1818         int             year
1819         int             wday
1820         int             yday
1821         int             isdst
1822     CODE:
1823         {
1824             struct tm mytm;
1825             init_tm(&mytm);     /* XXX workaround - see init_tm() above */
1826             mytm.tm_sec = sec;
1827             mytm.tm_min = min;
1828             mytm.tm_hour = hour;
1829             mytm.tm_mday = mday;
1830             mytm.tm_mon = mon;
1831             mytm.tm_year = year;
1832             mytm.tm_wday = wday;
1833             mytm.tm_yday = yday;
1834             mytm.tm_isdst = isdst;
1835             RETVAL = asctime(&mytm);
1836         }
1837     OUTPUT:
1838         RETVAL
1839
1840 long
1841 clock()
1842
1843 char *
1844 ctime(time)
1845         Time_t          &time
1846
1847 void
1848 times()
1849         PPCODE:
1850         struct tms tms;
1851         clock_t realtime;
1852         realtime = times( &tms );
1853         EXTEND(SP,5);
1854         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
1855         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
1856         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
1857         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
1858         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
1859
1860 double
1861 difftime(time1, time2)
1862         Time_t          time1
1863         Time_t          time2
1864
1865 SysRetLong
1866 mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1867         int             sec
1868         int             min
1869         int             hour
1870         int             mday
1871         int             mon
1872         int             year
1873         int             wday
1874         int             yday
1875         int             isdst
1876     CODE:
1877         {
1878             struct tm mytm;
1879             init_tm(&mytm);     /* XXX workaround - see init_tm() above */
1880             mytm.tm_sec = sec;
1881             mytm.tm_min = min;
1882             mytm.tm_hour = hour;
1883             mytm.tm_mday = mday;
1884             mytm.tm_mon = mon;
1885             mytm.tm_year = year;
1886             mytm.tm_wday = wday;
1887             mytm.tm_yday = yday;
1888             mytm.tm_isdst = isdst;
1889             RETVAL = (SysRetLong) mktime(&mytm);
1890         }
1891     OUTPUT:
1892         RETVAL
1893
1894 #XXX: if $xsubpp::WantOptimize is always the default
1895 #     sv_setpv(TARG, ...) could be used rather than
1896 #     ST(0) = sv_2mortal(newSVpv(...))
1897 void
1898 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
1899         SV *            fmt
1900         int             sec
1901         int             min
1902         int             hour
1903         int             mday
1904         int             mon
1905         int             year
1906         int             wday
1907         int             yday
1908         int             isdst
1909     CODE:
1910         {
1911             char *buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
1912             if (buf) {
1913                 SV *const sv = sv_newmortal();
1914                 sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL);
1915                 if (SvUTF8(fmt)) {
1916                     SvUTF8_on(sv);
1917                 }
1918                 ST(0) = sv;
1919             }
1920         }
1921
1922 void
1923 tzset()
1924   PPCODE:
1925     my_tzset(aTHX);
1926
1927 void
1928 tzname()
1929     PPCODE:
1930         EXTEND(SP,2);
1931         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
1932         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
1933
1934 SysRet
1935 access(filename, mode)
1936         char *          filename
1937         Mode_t          mode
1938
1939 char *
1940 ctermid(s = 0)
1941         char *          s = 0;
1942     CODE:
1943 #ifdef HAS_CTERMID_R
1944         s = (char *) safemalloc((size_t) L_ctermid);
1945 #endif
1946         RETVAL = ctermid(s);
1947     OUTPUT:
1948         RETVAL
1949     CLEANUP:
1950 #ifdef HAS_CTERMID_R
1951         Safefree(s);
1952 #endif
1953
1954 char *
1955 cuserid(s = 0)
1956         char *          s = 0;
1957     CODE:
1958 #ifdef HAS_CUSERID
1959   RETVAL = cuserid(s);
1960 #else
1961   RETVAL = 0;
1962   not_here("cuserid");
1963 #endif
1964     OUTPUT:
1965   RETVAL
1966
1967 SysRetLong
1968 fpathconf(fd, name)
1969         int             fd
1970         int             name
1971
1972 SysRetLong
1973 pathconf(filename, name)
1974         char *          filename
1975         int             name
1976
1977 SysRet
1978 pause()
1979
1980 SysRet
1981 setgid(gid)
1982         Gid_t           gid
1983     CLEANUP:
1984 #ifndef WIN32
1985         if (RETVAL >= 0) {
1986             PL_gid  = getgid();
1987             PL_egid = getegid();
1988         }
1989 #endif
1990
1991 SysRet
1992 setuid(uid)
1993         Uid_t           uid
1994     CLEANUP:
1995 #ifndef WIN32
1996         if (RETVAL >= 0) {
1997             PL_uid  = getuid();
1998             PL_euid = geteuid();
1999         }
2000 #endif
2001
2002 SysRetLong
2003 sysconf(name)
2004         int             name
2005
2006 char *
2007 ttyname(fd)
2008         int             fd
2009
2010 void
2011 getcwd()
2012     PPCODE:
2013       {
2014         dXSTARG;
2015         getcwd_sv(TARG);
2016         XSprePUSH; PUSHTARG;
2017       }
2018
2019 SysRet
2020 lchown(uid, gid, path)
2021        Uid_t           uid
2022        Gid_t           gid
2023        char *          path
2024     CODE:
2025 #ifdef HAS_LCHOWN
2026        /* yes, the order of arguments is different,
2027         * but consistent with CORE::chown() */
2028        RETVAL = lchown(path, uid, gid);
2029 #else
2030        RETVAL = not_here("lchown");
2031 #endif
2032     OUTPUT:
2033        RETVAL