ext/POSIX/POSIX.xs

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