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