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