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