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
1519 SysRet
1520 sigprocmask(how, sigset, oldsigset = 0)
1521         int                     how
1522         POSIX::SigSet           sigset = NO_INIT
1523         POSIX::SigSet           oldsigset = NO_INIT
1524 INIT:
1525         if (! SvOK(ST(1))) {
1526             sigset = NULL;
1527         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
1528             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
1529         } else {
1530             croak("sigset is not of type POSIX::SigSet");
1531         }
1532
1533         if (items < 3 || ! SvOK(ST(2))) {
1534             oldsigset = NULL;
1535         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
1536             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
1537         } else {
1538             croak("oldsigset is not of type POSIX::SigSet");
1539         }
1540
1541 SysRet
1542 sigsuspend(signal_mask)
1543         POSIX::SigSet           signal_mask
1544
1545 void
1546 _exit(status)
1547         int             status
1548
1549 SysRet
1550 close(fd)
1551         int             fd
1552
1553 SysRet
1554 dup(fd)
1555         int             fd
1556
1557 SysRet
1558 dup2(fd1, fd2)
1559         int             fd1
1560         int             fd2
1561
1562 SV *
1563 lseek(fd, offset, whence)
1564         int             fd
1565         Off_t           offset
1566         int             whence
1567     CODE:
1568         Off_t pos = PerlLIO_lseek(fd, offset, whence);
1569         RETVAL = sizeof(Off_t) > sizeof(IV)
1570                  ? newSVnv((NV)pos) : newSViv((IV)pos);
1571     OUTPUT:
1572         RETVAL
1573
1574 void
1575 nice(incr)
1576         int             incr
1577     PPCODE:
1578         errno = 0;
1579         if ((incr = nice(incr)) != -1 || errno == 0) {
1580             if (incr == 0)
1581                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
1582             else
1583                 XPUSHs(sv_2mortal(newSViv(incr)));
1584         }
1585
1586 void
1587 pipe()
1588     PPCODE:
1589         int fds[2];
1590         if (pipe(fds) != -1) {
1591             EXTEND(SP,2);
1592             PUSHs(sv_2mortal(newSViv(fds[0])));
1593             PUSHs(sv_2mortal(newSViv(fds[1])));
1594         }
1595
1596 SysRet
1597 read(fd, buffer, nbytes)
1598     PREINIT:
1599         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
1600     INPUT:
1601         int             fd
1602         size_t          nbytes
1603         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
1604     CLEANUP:
1605         if (RETVAL >= 0) {
1606             SvCUR_set(sv_buffer, RETVAL);
1607             SvPOK_only(sv_buffer);
1608             *SvEND(sv_buffer) = '\0';
1609             SvTAINTED_on(sv_buffer);
1610         }
1611
1612 SysRet
1613 setpgid(pid, pgid)
1614         pid_t           pid
1615         pid_t           pgid
1616
1617 pid_t
1618 setsid()
1619
1620 pid_t
1621 tcgetpgrp(fd)
1622         int             fd
1623
1624 SysRet
1625 tcsetpgrp(fd, pgrp_id)
1626         int             fd
1627         pid_t           pgrp_id
1628
1629 void
1630 uname()
1631     PPCODE:
1632 #ifdef HAS_UNAME
1633         struct utsname buf;
1634         if (uname(&buf) >= 0) {
1635             EXTEND(SP, 5);
1636             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
1637             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
1638             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
1639             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
1640             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
1641         }
1642 #else
1643         uname((char *) 0); /* A stub to call not_here(). */
1644 #endif
1645
1646 SysRet
1647 write(fd, buffer, nbytes)
1648         int             fd
1649         char *          buffer
1650         size_t          nbytes
1651
1652 SV *
1653 tmpnam()
1654     PREINIT:
1655         STRLEN i;
1656         int len;
1657     CODE:
1658         RETVAL = newSVpvn("", 0);
1659         SvGROW(RETVAL, L_tmpnam);
1660         len = strlen(tmpnam(SvPV(RETVAL, i)));
1661         SvCUR_set(RETVAL, len);
1662     OUTPUT:
1663         RETVAL
1664
1665 void
1666 abort()
1667
1668 int
1669 mblen(s, n)
1670         char *          s
1671         size_t          n
1672
1673 size_t
1674 mbstowcs(s, pwcs, n)
1675         wchar_t *       s
1676         char *          pwcs
1677         size_t          n
1678
1679 int
1680 mbtowc(pwc, s, n)
1681         wchar_t *       pwc
1682         char *          s
1683         size_t          n
1684
1685 int
1686 wcstombs(s, pwcs, n)
1687         char *          s
1688         wchar_t *       pwcs
1689         size_t          n
1690
1691 int
1692 wctomb(s, wchar)
1693         char *          s
1694         wchar_t         wchar
1695
1696 int
1697 strcoll(s1, s2)
1698         char *          s1
1699         char *          s2
1700
1701 void
1702 strtod(str)
1703         char *          str
1704     PREINIT:
1705         double num;
1706         char *unparsed;
1707     PPCODE:
1708         SET_NUMERIC_LOCAL();
1709         num = strtod(str, &unparsed);
1710         PUSHs(sv_2mortal(newSVnv(num)));
1711         if (GIMME == G_ARRAY) {
1712             EXTEND(SP, 1);
1713             if (unparsed)
1714                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1715             else
1716                 PUSHs(&PL_sv_undef);
1717         }
1718
1719 void
1720 strtol(str, base = 0)
1721         char *          str
1722         int             base
1723     PREINIT:
1724         long num;
1725         char *unparsed;
1726     PPCODE:
1727         num = strtol(str, &unparsed, base);
1728 #if IVSIZE <= LONGSIZE
1729         if (num < IV_MIN || num > IV_MAX)
1730             PUSHs(sv_2mortal(newSVnv((double)num)));
1731         else
1732 #endif
1733             PUSHs(sv_2mortal(newSViv((IV)num)));
1734         if (GIMME == G_ARRAY) {
1735             EXTEND(SP, 1);
1736             if (unparsed)
1737                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1738             else
1739                 PUSHs(&PL_sv_undef);
1740         }
1741
1742 void
1743 strtoul(str, base = 0)
1744         const char *    str
1745         int             base
1746     PREINIT:
1747         unsigned long num;
1748         char *unparsed;
1749     PPCODE:
1750         num = strtoul(str, &unparsed, base);
1751 #if IVSIZE <= LONGSIZE
1752         if (num > IV_MAX)
1753             PUSHs(sv_2mortal(newSVnv((double)num)));
1754         else
1755 #endif
1756             PUSHs(sv_2mortal(newSViv((IV)num)));
1757         if (GIMME == G_ARRAY) {
1758             EXTEND(SP, 1);
1759             if (unparsed)
1760                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
1761             else
1762                 PUSHs(&PL_sv_undef);
1763         }
1764
1765 void
1766 strxfrm(src)
1767         SV *            src
1768     CODE:
1769         {
1770           STRLEN srclen;
1771           STRLEN dstlen;
1772           char *p = SvPV(src,srclen);
1773           srclen++;
1774           ST(0) = sv_2mortal(newSV(srclen*4+1));
1775           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
1776           if (dstlen > srclen) {
1777               dstlen++;
1778               SvGROW(ST(0), dstlen);
1779               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
1780               dstlen--;
1781           }
1782           SvCUR_set(ST(0), dstlen);
1783             SvPOK_only(ST(0));
1784         }
1785
1786 SysRet
1787 mkfifo(filename, mode)
1788         char *          filename
1789         Mode_t          mode
1790     CODE:
1791         TAINT_PROPER("mkfifo");
1792         RETVAL = mkfifo(filename, mode);
1793     OUTPUT:
1794         RETVAL
1795
1796 SysRet
1797 tcdrain(fd)
1798         int             fd
1799
1800
1801 SysRet
1802 tcflow(fd, action)
1803         int             fd
1804         int             action
1805
1806
1807 SysRet
1808 tcflush(fd, queue_selector)
1809         int             fd
1810         int             queue_selector
1811
1812 SysRet
1813 tcsendbreak(fd, duration)
1814         int             fd
1815         int             duration
1816
1817 char *
1818 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1819         int             sec
1820         int             min
1821         int             hour
1822         int             mday
1823         int             mon
1824         int             year
1825         int             wday
1826         int             yday
1827         int             isdst
1828     CODE:
1829         {
1830             struct tm mytm;
1831             init_tm(&mytm);     /* XXX workaround - see init_tm() above */
1832             mytm.tm_sec = sec;
1833             mytm.tm_min = min;
1834             mytm.tm_hour = hour;
1835             mytm.tm_mday = mday;
1836             mytm.tm_mon = mon;
1837             mytm.tm_year = year;
1838             mytm.tm_wday = wday;
1839             mytm.tm_yday = yday;
1840             mytm.tm_isdst = isdst;
1841             RETVAL = asctime(&mytm);
1842         }
1843     OUTPUT:
1844         RETVAL
1845
1846 long
1847 clock()
1848
1849 char *
1850 ctime(time)
1851         Time_t          &time
1852
1853 void
1854 times()
1855         PPCODE:
1856         struct tms tms;
1857         clock_t realtime;
1858         realtime = times( &tms );
1859         EXTEND(SP,5);
1860         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
1861         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
1862         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
1863         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
1864         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
1865
1866 double
1867 difftime(time1, time2)
1868         Time_t          time1
1869         Time_t          time2
1870
1871 SysRetLong
1872 mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
1873         int             sec
1874         int             min
1875         int             hour
1876         int             mday
1877         int             mon
1878         int             year
1879         int             wday
1880         int             yday
1881         int             isdst
1882     CODE:
1883         {
1884             struct tm mytm;
1885             init_tm(&mytm);     /* XXX workaround - see init_tm() above */
1886             mytm.tm_sec = sec;
1887             mytm.tm_min = min;
1888             mytm.tm_hour = hour;
1889             mytm.tm_mday = mday;
1890             mytm.tm_mon = mon;
1891             mytm.tm_year = year;
1892             mytm.tm_wday = wday;
1893             mytm.tm_yday = yday;
1894             mytm.tm_isdst = isdst;
1895             RETVAL = (SysRetLong) mktime(&mytm);
1896         }
1897     OUTPUT:
1898         RETVAL
1899
1900 #XXX: if $xsubpp::WantOptimize is always the default
1901 #     sv_setpv(TARG, ...) could be used rather than
1902 #     ST(0) = sv_2mortal(newSVpv(...))
1903 void
1904 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
1905         SV *            fmt
1906         int             sec
1907         int             min
1908         int             hour
1909         int             mday
1910         int             mon
1911         int             year
1912         int             wday
1913         int             yday
1914         int             isdst
1915     CODE:
1916         {
1917             char *buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
1918             if (buf) {
1919                 SV *const sv = sv_newmortal();
1920                 sv_usepvn_flags(sv, buf, strlen(buf), SV_HAS_TRAILING_NUL);
1921                 if (SvUTF8(fmt)) {
1922                     SvUTF8_on(sv);
1923                 }
1924                 ST(0) = sv;
1925             }
1926         }
1927
1928 void
1929 tzset()
1930   PPCODE:
1931     my_tzset(aTHX);
1932
1933 void
1934 tzname()
1935     PPCODE:
1936         EXTEND(SP,2);
1937         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
1938         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
1939
1940 SysRet
1941 access(filename, mode)
1942         char *          filename
1943         Mode_t          mode
1944
1945 char *
1946 ctermid(s = 0)
1947         char *          s = 0;
1948     CODE:
1949 #ifdef HAS_CTERMID_R
1950         s = (char *) safemalloc((size_t) L_ctermid);
1951 #endif
1952         RETVAL = ctermid(s);
1953     OUTPUT:
1954         RETVAL
1955     CLEANUP:
1956 #ifdef HAS_CTERMID_R
1957         Safefree(s);
1958 #endif
1959
1960 char *
1961 cuserid(s = 0)
1962         char *          s = 0;
1963     CODE:
1964 #ifdef HAS_CUSERID
1965   RETVAL = cuserid(s);
1966 #else
1967   RETVAL = 0;
1968   not_here("cuserid");
1969 #endif
1970     OUTPUT:
1971   RETVAL
1972
1973 SysRetLong
1974 fpathconf(fd, name)
1975         int             fd
1976         int             name
1977
1978 SysRetLong
1979 pathconf(filename, name)
1980         char *          filename
1981         int             name
1982
1983 SysRet
1984 pause()
1985
1986 SysRet
1987 setgid(gid)
1988         Gid_t           gid
1989     CLEANUP:
1990 #ifndef WIN32
1991         if (RETVAL >= 0) {
1992             PL_gid  = getgid();
1993             PL_egid = getegid();
1994         }
1995 #endif
1996
1997 SysRet
1998 setuid(uid)
1999         Uid_t           uid
2000     CLEANUP:
2001 #ifndef WIN32
2002         if (RETVAL >= 0) {
2003             PL_uid  = getuid();
2004             PL_euid = geteuid();
2005         }
2006 #endif
2007
2008 SysRetLong
2009 sysconf(name)
2010         int             name
2011
2012 char *
2013 ttyname(fd)
2014         int             fd
2015
2016 void
2017 getcwd()
2018     PPCODE:
2019       {
2020         dXSTARG;
2021         getcwd_sv(TARG);
2022         XSprePUSH; PUSHTARG;
2023       }
2024
2025 SysRet
2026 lchown(uid, gid, path)
2027        Uid_t           uid
2028        Gid_t           gid
2029        char *          path
2030     CODE:
2031 #ifdef HAS_LCHOWN
2032        /* yes, the order of arguments is different,
2033         * but consistent with CORE::chown() */
2034        RETVAL = lchown(path, uid, gid);
2035 #else
2036        RETVAL = not_here("lchown");
2037 #endif
2038     OUTPUT:
2039        RETVAL