ext/POSIX/POSIX.xs

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