1 /* pp_sys.c 2 * 3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * But only a short way ahead its floor and the walls on either side were 13 * cloven by a great fissure, out of which the red glare came, now leaping 14 * up, now dying down into darkness; and all the while far below there was 15 * a rumour and a trouble as of great engines throbbing and labouring. 16 * 17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"] 18 */ 19 20 /* This file contains system pp ("push/pop") functions that 21 * execute the opcodes that make up a perl program. A typical pp function 22 * expects to find its arguments on the stack, and usually pushes its 23 * results onto the stack, hence the 'pp' terminology. Each OP structure 24 * contains a pointer to the relevant pp_foo() function. 25 * 26 * By 'system', we mean ops which interact with the OS, such as pp_open(). 27 */ 28 29 #include "EXTERN.h" 30 #define PERL_IN_PP_SYS_C 31 #include "perl.h" 32 #include "time64.h" 33 #include "syscall_emulator.h" 34 #define syscall syscall_emulator 35 36 #ifdef I_SHADOW 37 /* Shadow password support for solaris - pdo@cs.umd.edu 38 * Not just Solaris: at least HP-UX, IRIX, Linux. 39 * The API is from SysV. 40 * 41 * There are at least two more shadow interfaces, 42 * see the comments in pp_gpwent(). 43 * 44 * --jhi */ 45 # ifdef __hpux__ 46 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h> 47 * and another MAXINT from "perl.h" <- <sys/param.h>. */ 48 # undef MAXINT 49 # endif 50 # include <shadow.h> 51 #endif 52 53 #ifdef I_SYS_RESOURCE 54 # include <sys/resource.h> 55 #endif 56 57 #ifdef HAS_SELECT 58 # ifdef I_SYS_SELECT 59 # include <sys/select.h> 60 # endif 61 #endif 62 63 #ifdef I_SYS_SYSCALL 64 # include <sys/syscall.h> 65 #endif 66 67 /* XXX Configure test needed. 68 h_errno might not be a simple 'int', especially for multi-threaded 69 applications, see "extern int errno in perl.h". Creating such 70 a test requires taking into account the differences between 71 compiling multithreaded and singlethreaded ($ccflags et al). 72 HOST_NOT_FOUND is typically defined in <netdb.h>. 73 */ 74 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__) 75 extern int h_errno; 76 #endif 77 78 #ifdef HAS_PASSWD 79 # ifdef I_PWD 80 # include <pwd.h> 81 # elif !defined(VMS) 82 struct passwd *getpwnam (char *); 83 struct passwd *getpwuid (Uid_t); 84 # endif 85 # ifdef HAS_GETPWENT 86 # ifndef getpwent 87 struct passwd *getpwent (void); 88 # elif defined (VMS) && defined (my_getpwent) 89 struct passwd *Perl_my_getpwent (pTHX); 90 # endif 91 # endif 92 #endif 93 94 #ifdef HAS_GROUP 95 # ifdef I_GRP 96 # include <grp.h> 97 # else 98 struct group *getgrnam (char *); 99 struct group *getgrgid (Gid_t); 100 # endif 101 # ifdef HAS_GETGRENT 102 # ifndef getgrent 103 struct group *getgrent (void); 104 # endif 105 # endif 106 #endif 107 108 #ifdef I_UTIME 109 # if defined(_MSC_VER) || defined(__MINGW32__) 110 # include <sys/utime.h> 111 # else 112 # include <utime.h> 113 # endif 114 #endif 115 116 #ifdef HAS_CHSIZE 117 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ 118 # undef my_chsize 119 # endif 120 # define my_chsize PerlLIO_chsize 121 #elif defined(HAS_TRUNCATE) 122 # define my_chsize PerlLIO_chsize 123 #else 124 I32 my_chsize(int fd, Off_t length); 125 #endif 126 127 #ifdef HAS_FLOCK 128 # define FLOCK flock 129 #else /* no flock() */ 130 131 /* fcntl.h might not have been included, even if it exists, because 132 the current Configure only sets I_FCNTL if it's needed to pick up 133 the *_OK constants. Make sure it has been included before testing 134 the fcntl() locking constants. */ 135 # if defined(HAS_FCNTL) && !defined(I_FCNTL) 136 # include <fcntl.h> 137 # endif 138 139 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK) 140 # define FLOCK fcntl_emulate_flock 141 # define FCNTL_EMULATE_FLOCK 142 # elif defined(HAS_LOCKF) 143 # define FLOCK lockf_emulate_flock 144 # define LOCKF_EMULATE_FLOCK 145 # endif 146 147 # ifdef FLOCK 148 static int FLOCK (int, int); 149 150 /* 151 * These are the flock() constants. Since this sytems doesn't have 152 * flock(), the values of the constants are probably not available. 153 */ 154 # ifndef LOCK_SH 155 # define LOCK_SH 1 156 # endif 157 # ifndef LOCK_EX 158 # define LOCK_EX 2 159 # endif 160 # ifndef LOCK_NB 161 # define LOCK_NB 4 162 # endif 163 # ifndef LOCK_UN 164 # define LOCK_UN 8 165 # endif 166 # endif /* emulating flock() */ 167 168 #endif /* no flock() */ 169 170 #define ZBTLEN 10 171 static const char zero_but_true[ZBTLEN + 1] = "0 but true"; 172 173 #if defined(I_SYS_ACCESS) && !defined(R_OK) 174 # include <sys/access.h> 175 #endif 176 177 #include "reentr.h" 178 179 #ifdef __Lynx__ 180 /* Missing protos on LynxOS */ 181 void sethostent(int); 182 void endhostent(void); 183 void setnetent(int); 184 void endnetent(void); 185 void setprotoent(int); 186 void endprotoent(void); 187 void setservent(int); 188 void endservent(void); 189 #endif 190 191 #ifdef __amigaos4__ 192 # include "amigaos4/amigaio.h" 193 #endif 194 195 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ 196 197 /* F_OK unused: if stat() cannot find it... */ 198 199 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) 200 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */ 201 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK)) 202 #endif 203 204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS) 205 # ifdef I_SYS_SECURITY 206 # include <sys/security.h> 207 # endif 208 # ifdef ACC_SELF 209 /* HP SecureWare */ 210 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF)) 211 # else 212 /* SCO */ 213 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f))) 214 # endif 215 #endif 216 217 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF) 218 /* AIX's accessx() doesn't declare its argument const, unlike every other platform */ 219 # define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF)) 220 #endif 221 222 223 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \ 224 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \ 225 || defined(HAS_SETREGID) || defined(HAS_SETRESGID)) 226 /* The Hard Way. */ 227 STATIC int 228 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) 229 { 230 const Uid_t ruid = getuid(); 231 const Uid_t euid = geteuid(); 232 const Gid_t rgid = getgid(); 233 const Gid_t egid = getegid(); 234 int res; 235 236 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) 237 Perl_croak(aTHX_ "switching effective uid is not implemented"); 238 #else 239 # ifdef HAS_SETREUID 240 if (setreuid(euid, ruid)) 241 # elif defined(HAS_SETRESUID) 242 if (setresuid(euid, ruid, (Uid_t)-1)) 243 # endif 244 /* diag_listed_as: entering effective %s failed */ 245 Perl_croak(aTHX_ "entering effective uid failed"); 246 #endif 247 248 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID) 249 Perl_croak(aTHX_ "switching effective gid is not implemented"); 250 #else 251 # ifdef HAS_SETREGID 252 if (setregid(egid, rgid)) 253 # elif defined(HAS_SETRESGID) 254 if (setresgid(egid, rgid, (Gid_t)-1)) 255 # endif 256 /* diag_listed_as: entering effective %s failed */ 257 Perl_croak(aTHX_ "entering effective gid failed"); 258 #endif 259 260 res = access(path, mode); 261 262 #ifdef HAS_SETREUID 263 if (setreuid(ruid, euid)) 264 #elif defined(HAS_SETRESUID) 265 if (setresuid(ruid, euid, (Uid_t)-1)) 266 #endif 267 /* diag_listed_as: leaving effective %s failed */ 268 Perl_croak(aTHX_ "leaving effective uid failed"); 269 270 #ifdef HAS_SETREGID 271 if (setregid(rgid, egid)) 272 #elif defined(HAS_SETRESGID) 273 if (setresgid(rgid, egid, (Gid_t)-1)) 274 #endif 275 /* diag_listed_as: leaving effective %s failed */ 276 Perl_croak(aTHX_ "leaving effective gid failed"); 277 278 return res; 279 } 280 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f))) 281 #endif 282 283 PP(pp_backtick) 284 { 285 dSP; dTARGET; 286 PerlIO *fp; 287 const char * const tmps = POPpconstx; 288 const U8 gimme = GIMME_V; 289 const char *mode = "r"; 290 291 TAINT_PROPER("``"); 292 if (PL_op->op_private & OPpOPEN_IN_RAW) 293 mode = "rb"; 294 else if (PL_op->op_private & OPpOPEN_IN_CRLF) 295 mode = "rt"; 296 fp = PerlProc_popen(tmps, mode); 297 if (fp) { 298 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL); 299 if (type && *type) 300 PerlIO_apply_layers(aTHX_ fp,mode,type); 301 302 if (gimme == G_VOID) { 303 char tmpbuf[256]; 304 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) 305 NOOP; 306 } 307 else if (gimme == G_SCALAR) { 308 ENTER_with_name("backtick"); 309 SAVESPTR(PL_rs); 310 PL_rs = &PL_sv_undef; 311 SvPVCLEAR(TARG); /* note that this preserves previous buffer */ 312 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) 313 NOOP; 314 LEAVE_with_name("backtick"); 315 XPUSHs(TARG); 316 SvTAINTED_on(TARG); 317 } 318 else { 319 for (;;) { 320 SV * const sv = newSV(79); 321 if (sv_gets(sv, fp, 0) == NULL) { 322 SvREFCNT_dec(sv); 323 break; 324 } 325 mXPUSHs(sv); 326 if (SvLEN(sv) - SvCUR(sv) > 20) { 327 SvPV_shrink_to_cur(sv); 328 } 329 SvTAINTED_on(sv); 330 } 331 } 332 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp)); 333 TAINT; /* "I believe that this is not gratuitous!" */ 334 } 335 else { 336 STATUS_NATIVE_CHILD_SET(-1); 337 if (gimme == G_SCALAR) 338 RETPUSHUNDEF; 339 } 340 341 RETURN; 342 } 343 344 PP(pp_glob) 345 { 346 OP *result; 347 dSP; 348 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; 349 350 PUTBACK; 351 352 /* make a copy of the pattern if it is gmagical, to ensure that magic 353 * is called once and only once */ 354 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs)); 355 356 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); 357 358 if (PL_op->op_flags & OPf_SPECIAL) { 359 /* call Perl-level glob function instead. Stack args are: 360 * MARK, wildcard 361 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub 362 * */ 363 return NORMAL; 364 } 365 if (PL_globhook) { 366 PL_globhook(aTHX); 367 return NORMAL; 368 } 369 370 /* Note that we only ever get here if File::Glob fails to load 371 * without at the same time croaking, for some reason, or if 372 * perl was built with PERL_EXTERNAL_GLOB */ 373 374 ENTER_with_name("glob"); 375 376 #ifndef VMS 377 if (TAINTING_get) { 378 /* 379 * The external globbing program may use things we can't control, 380 * so for security reasons we must assume the worst. 381 */ 382 TAINT; 383 taint_proper(PL_no_security, "glob"); 384 } 385 #endif /* !VMS */ 386 387 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */ 388 PL_last_in_gv = gv; 389 390 SAVESPTR(PL_rs); /* This is not permanent, either. */ 391 PL_rs = newSVpvs_flags("\000", SVs_TEMP); 392 #ifndef DOSISH 393 #ifndef CSH 394 *SvPVX(PL_rs) = '\n'; 395 #endif /* !CSH */ 396 #endif /* !DOSISH */ 397 398 result = do_readline(); 399 LEAVE_with_name("glob"); 400 return result; 401 } 402 403 PP(pp_rcatline) 404 { 405 PL_last_in_gv = cGVOP_gv; 406 return do_readline(); 407 } 408 409 PP(pp_warn) 410 { 411 dSP; dMARK; 412 SV *exsv; 413 STRLEN len; 414 if (SP - MARK > 1) { 415 dTARGET; 416 do_join(TARG, &PL_sv_no, MARK, SP); 417 exsv = TARG; 418 SP = MARK + 1; 419 } 420 else if (SP == MARK) { 421 exsv = &PL_sv_no; 422 MEXTEND(SP, 1); 423 SP = MARK + 1; 424 } 425 else { 426 exsv = TOPs; 427 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv); 428 } 429 430 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { 431 /* well-formed exception supplied */ 432 } 433 else { 434 SV * const errsv = ERRSV; 435 SvGETMAGIC(errsv); 436 if (SvROK(errsv)) { 437 if (SvGMAGICAL(errsv)) { 438 exsv = sv_newmortal(); 439 sv_setsv_nomg(exsv, errsv); 440 } 441 else exsv = errsv; 442 } 443 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) { 444 exsv = sv_newmortal(); 445 sv_setsv_nomg(exsv, errsv); 446 sv_catpvs(exsv, "\t...caught"); 447 } 448 else { 449 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); 450 } 451 } 452 if (SvROK(exsv) && !PL_warnhook) 453 Perl_warn(aTHX_ "%" SVf, SVfARG(exsv)); 454 else warn_sv(exsv); 455 RETSETYES; 456 } 457 458 PP(pp_die) 459 { 460 dSP; dMARK; 461 SV *exsv; 462 STRLEN len; 463 #ifdef VMS 464 VMSISH_HUSHED = 465 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH); 466 #endif 467 if (SP - MARK != 1) { 468 dTARGET; 469 do_join(TARG, &PL_sv_no, MARK, SP); 470 exsv = TARG; 471 SP = MARK + 1; 472 } 473 else { 474 exsv = TOPs; 475 } 476 477 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { 478 /* well-formed exception supplied */ 479 } 480 else { 481 SV * const errsv = ERRSV; 482 SvGETMAGIC(errsv); 483 if (SvROK(errsv)) { 484 exsv = errsv; 485 if (sv_isobject(exsv)) { 486 HV * const stash = SvSTASH(SvRV(exsv)); 487 GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); 488 if (gv) { 489 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); 490 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); 491 EXTEND(SP, 3); 492 PUSHMARK(SP); 493 PUSHs(exsv); 494 PUSHs(file); 495 PUSHs(line); 496 PUTBACK; 497 call_sv(MUTABLE_SV(GvCV(gv)), 498 G_SCALAR|G_EVAL|G_KEEPERR); 499 exsv = sv_mortalcopy(*PL_stack_sp--); 500 } 501 } 502 } 503 else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) { 504 exsv = sv_mortalcopy(errsv); 505 sv_catpvs(exsv, "\t...propagated"); 506 } 507 else { 508 exsv = newSVpvs_flags("Died", SVs_TEMP); 509 } 510 } 511 die_sv(exsv); 512 NOT_REACHED; /* NOTREACHED */ 513 return NULL; /* avoid missing return from non-void function warning */ 514 } 515 516 /* I/O. */ 517 518 OP * 519 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, 520 const MAGIC *const mg, const U32 flags, U32 argc, ...) 521 { 522 SV **orig_sp = sp; 523 I32 ret_args; 524 SSize_t extend_size; 525 526 PERL_ARGS_ASSERT_TIED_METHOD; 527 528 /* Ensure that our flag bits do not overlap. */ 529 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); 530 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); 531 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0); 532 533 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ 534 PUSHSTACKi(PERLSI_MAGIC); 535 /* extend for object + args. If argc might wrap/truncate when cast 536 * to SSize_t and incremented, set to -1, which will trigger a panic in 537 * EXTEND(). 538 * The weird way this is written is because g++ is dumb enough to 539 * warn "comparison is always false" on something like: 540 * 541 * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1 542 * 543 * (where the LH condition is false) 544 */ 545 extend_size = 546 (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc)) 547 ? -1 : (SSize_t)argc + 1; 548 EXTEND(SP, extend_size); 549 PUSHMARK(sp); 550 PUSHs(SvTIED_obj(sv, mg)); 551 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { 552 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */ 553 sp += argc; 554 } 555 else if (argc) { 556 const U32 mortalize_not_needed 557 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; 558 va_list args; 559 va_start(args, argc); 560 do { 561 SV *const arg = va_arg(args, SV *); 562 if(mortalize_not_needed) 563 PUSHs(arg); 564 else 565 mPUSHs(arg); 566 } while (--argc); 567 va_end(args); 568 } 569 570 PUTBACK; 571 ENTER_with_name("call_tied_method"); 572 if (flags & TIED_METHOD_SAY) { 573 /* local $\ = "\n" */ 574 SAVEGENERICSV(PL_ors_sv); 575 PL_ors_sv = newSVpvs("\n"); 576 } 577 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED); 578 SPAGAIN; 579 orig_sp = sp; 580 POPSTACK; 581 SPAGAIN; 582 if (ret_args) { /* copy results back to original stack */ 583 EXTEND(sp, ret_args); 584 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*); 585 sp += ret_args; 586 PUTBACK; 587 } 588 LEAVE_with_name("call_tied_method"); 589 return NORMAL; 590 } 591 592 #define tied_method0(a,b,c,d) \ 593 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0) 594 #define tied_method1(a,b,c,d,e) \ 595 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e) 596 #define tied_method2(a,b,c,d,e,f) \ 597 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f) 598 599 PP(pp_open) 600 { 601 dSP; 602 dMARK; dORIGMARK; 603 dTARGET; 604 SV *sv; 605 IO *io; 606 const char *tmps; 607 STRLEN len; 608 bool ok; 609 610 GV * const gv = MUTABLE_GV(*++MARK); 611 612 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv))) 613 DIE(aTHX_ PL_no_usym, "filehandle"); 614 615 if ((io = GvIOp(gv))) { 616 const MAGIC *mg; 617 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; 618 619 if (IoDIRP(io)) 620 Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle", 621 HEKfARG(GvENAME_HEK(gv))); 622 623 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 624 if (mg) { 625 /* Method's args are same as ours ... */ 626 /* ... except handle is replaced by the object */ 627 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg, 628 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, 629 sp - mark); 630 } 631 } 632 633 if (MARK < SP) { 634 sv = *++MARK; 635 } 636 else { 637 sv = GvSVn(gv); 638 } 639 640 tmps = SvPV_const(sv, len); 641 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK)); 642 SP = ORIGMARK; 643 if (ok) 644 PUSHi( (I32)PL_forkprocess ); 645 else if (PL_forkprocess == 0) /* we are a new child */ 646 PUSHs(&PL_sv_zero); 647 else 648 RETPUSHUNDEF; 649 RETURN; 650 } 651 652 PP(pp_close) 653 { 654 dSP; 655 /* pp_coreargs pushes a NULL to indicate no args passed to 656 * CORE::close() */ 657 GV * const gv = 658 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); 659 660 if (MAXARG == 0) 661 EXTEND(SP, 1); 662 663 if (gv) { 664 IO * const io = GvIO(gv); 665 if (io) { 666 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 667 if (mg) { 668 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg); 669 } 670 } 671 } 672 PUSHs(boolSV(do_close(gv, TRUE))); 673 RETURN; 674 } 675 676 PP(pp_pipe_op) 677 { 678 #ifdef HAS_PIPE 679 dSP; 680 IO *rstio; 681 IO *wstio; 682 int fd[2]; 683 684 GV * const wgv = MUTABLE_GV(POPs); 685 GV * const rgv = MUTABLE_GV(POPs); 686 687 rstio = GvIOn(rgv); 688 if (IoIFP(rstio)) 689 do_close(rgv, FALSE); 690 691 wstio = GvIOn(wgv); 692 if (IoIFP(wstio)) 693 do_close(wgv, FALSE); 694 695 if (PerlProc_pipe_cloexec(fd) < 0) 696 goto badexit; 697 698 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE); 699 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE); 700 IoOFP(rstio) = IoIFP(rstio); 701 IoIFP(wstio) = IoOFP(wstio); 702 IoTYPE(rstio) = IoTYPE_RDONLY; 703 IoTYPE(wstio) = IoTYPE_WRONLY; 704 705 if (!IoIFP(rstio) || !IoOFP(wstio)) { 706 if (IoIFP(rstio)) 707 PerlIO_close(IoIFP(rstio)); 708 else 709 PerlLIO_close(fd[0]); 710 if (IoOFP(wstio)) 711 PerlIO_close(IoOFP(wstio)); 712 else 713 PerlLIO_close(fd[1]); 714 goto badexit; 715 } 716 RETPUSHYES; 717 718 badexit: 719 RETPUSHUNDEF; 720 #else 721 DIE(aTHX_ PL_no_func, "pipe"); 722 #endif 723 } 724 725 PP(pp_fileno) 726 { 727 dSP; dTARGET; 728 GV *gv; 729 IO *io; 730 PerlIO *fp; 731 const MAGIC *mg; 732 733 if (MAXARG < 1) 734 RETPUSHUNDEF; 735 gv = MUTABLE_GV(POPs); 736 io = GvIO(gv); 737 738 if (io 739 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 740 { 741 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg); 742 } 743 744 if (io && IoDIRP(io)) { 745 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD) 746 PUSHi(my_dirfd(IoDIRP(io))); 747 RETURN; 748 #elif defined(ENOTSUP) 749 errno = ENOTSUP; /* Operation not supported */ 750 RETPUSHUNDEF; 751 #elif defined(EOPNOTSUPP) 752 errno = EOPNOTSUPP; /* Operation not supported on socket */ 753 RETPUSHUNDEF; 754 #else 755 errno = EINVAL; /* Invalid argument */ 756 RETPUSHUNDEF; 757 #endif 758 } 759 760 if (!io || !(fp = IoIFP(io))) { 761 /* Can't do this because people seem to do things like 762 defined(fileno($foo)) to check whether $foo is a valid fh. 763 764 report_evil_fh(gv); 765 */ 766 RETPUSHUNDEF; 767 } 768 769 PUSHi(PerlIO_fileno(fp)); 770 RETURN; 771 } 772 773 PP(pp_umask) 774 { 775 dSP; 776 #ifdef HAS_UMASK 777 dTARGET; 778 Mode_t anum; 779 780 if (MAXARG < 1 || (!TOPs && !POPs)) { 781 anum = PerlLIO_umask(022); 782 /* setting it to 022 between the two calls to umask avoids 783 * to have a window where the umask is set to 0 -- meaning 784 * that another thread could create world-writeable files. */ 785 if (anum != 022) 786 (void)PerlLIO_umask(anum); 787 } 788 else 789 anum = PerlLIO_umask(POPi); 790 TAINT_PROPER("umask"); 791 XPUSHi(anum); 792 #else 793 /* Only DIE if trying to restrict permissions on "user" (self). 794 * Otherwise it's harmless and more useful to just return undef 795 * since 'group' and 'other' concepts probably don't exist here. */ 796 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700)) 797 DIE(aTHX_ "umask not implemented"); 798 XPUSHs(&PL_sv_undef); 799 #endif 800 RETURN; 801 } 802 803 PP(pp_binmode) 804 { 805 dSP; 806 GV *gv; 807 IO *io; 808 PerlIO *fp; 809 SV *discp = NULL; 810 811 if (MAXARG < 1) 812 RETPUSHUNDEF; 813 if (MAXARG > 1) { 814 discp = POPs; 815 } 816 817 gv = MUTABLE_GV(POPs); 818 io = GvIO(gv); 819 820 if (io) { 821 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 822 if (mg) { 823 /* This takes advantage of the implementation of the varargs 824 function, which I don't think that the optimiser will be able to 825 figure out. Although, as it's a static function, in theory it 826 could. */ 827 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg, 828 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, 829 discp ? 1 : 0, discp); 830 } 831 } 832 833 if (!io || !(fp = IoIFP(io))) { 834 report_evil_fh(gv); 835 SETERRNO(EBADF,RMS_IFI); 836 RETPUSHUNDEF; 837 } 838 839 PUTBACK; 840 { 841 STRLEN len = 0; 842 const char *d = NULL; 843 int mode; 844 if (discp) 845 d = SvPV_const(discp, len); 846 mode = mode_from_discipline(d, len); 847 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) { 848 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 849 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) { 850 SPAGAIN; 851 RETPUSHUNDEF; 852 } 853 } 854 SPAGAIN; 855 RETPUSHYES; 856 } 857 else { 858 SPAGAIN; 859 RETPUSHUNDEF; 860 } 861 } 862 } 863 864 PP(pp_tie) 865 { 866 dSP; dMARK; 867 HV* stash; 868 GV *gv = NULL; 869 SV *sv; 870 const I32 markoff = MARK - PL_stack_base; 871 const char *methname; 872 int how = PERL_MAGIC_tied; 873 U32 items; 874 SV *varsv = *++MARK; 875 876 switch(SvTYPE(varsv)) { 877 case SVt_PVHV: 878 { 879 HE *entry; 880 methname = "TIEHASH"; 881 if (HvLAZYDEL(varsv) && (entry = HvEITER_get((HV *)varsv))) { 882 HvLAZYDEL_off(varsv); 883 hv_free_ent(NULL, entry); 884 } 885 HvEITER_set(MUTABLE_HV(varsv), 0); 886 HvRITER_set(MUTABLE_HV(varsv), -1); 887 break; 888 } 889 case SVt_PVAV: 890 methname = "TIEARRAY"; 891 if (!AvREAL(varsv)) { 892 if (!AvREIFY(varsv)) 893 Perl_croak(aTHX_ "Cannot tie unreifiable array"); 894 av_clear((AV *)varsv); 895 AvREIFY_off(varsv); 896 AvREAL_on(varsv); 897 } 898 break; 899 case SVt_PVGV: 900 case SVt_PVLV: 901 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) { 902 methname = "TIEHANDLE"; 903 how = PERL_MAGIC_tiedscalar; 904 /* For tied filehandles, we apply tiedscalar magic to the IO 905 slot of the GP rather than the GV itself. AMS 20010812 */ 906 if (!GvIOp(varsv)) 907 GvIOp(varsv) = newIO(); 908 varsv = MUTABLE_SV(GvIOp(varsv)); 909 break; 910 } 911 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') { 912 vivify_defelem(varsv); 913 varsv = LvTARG(varsv); 914 } 915 /* FALLTHROUGH */ 916 default: 917 methname = "TIESCALAR"; 918 how = PERL_MAGIC_tiedscalar; 919 break; 920 } 921 items = SP - MARK++; 922 if (sv_isobject(*MARK)) { /* Calls GET magic. */ 923 ENTER_with_name("call_TIE"); 924 PUSHSTACKi(PERLSI_MAGIC); 925 PUSHMARK(SP); 926 EXTEND(SP,(I32)items); 927 while (items--) 928 PUSHs(*MARK++); 929 PUTBACK; 930 call_method(methname, G_SCALAR); 931 } 932 else { 933 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO" 934 * will attempt to invoke IO::File::TIEARRAY, with (best case) the 935 * wrong error message, and worse case, supreme action at a distance. 936 * (Sorry obfuscation writers. You're not going to be given this one.) 937 */ 938 stash = gv_stashsv(*MARK, 0); 939 if (!stash) { 940 if (SvROK(*MARK)) 941 DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX 942 " via package %" SVf_QUOTEDPREFIX, 943 methname, SVfARG(*MARK)); 944 else if (isGV(*MARK)) { 945 /* If the glob doesn't name an existing package, using 946 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So 947 * generate the name for the error message explicitly. */ 948 SV *stashname = sv_newmortal(); 949 gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE); 950 DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX 951 " via package %" SVf_QUOTEDPREFIX, 952 methname, SVfARG(stashname)); 953 } 954 else { 955 SV *stashname = !SvPOK(*MARK) ? &PL_sv_no 956 : SvCUR(*MARK) ? *MARK 957 : newSVpvs_flags("main", SVs_TEMP); 958 DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX 959 " via package %" SVf_QUOTEDPREFIX 960 " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)", 961 methname, SVfARG(stashname), SVfARG(stashname)); 962 } 963 } 964 else if (!(gv = gv_fetchmethod(stash, methname))) { 965 /* The effective name can only be NULL for stashes that have 966 * been deleted from the symbol table, which this one can't 967 * be, since we just looked it up by name. 968 */ 969 DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX 970 " via package %" HEKf_QUOTEDPREFIX , 971 methname, HvENAME_HEK_NN(stash)); 972 } 973 ENTER_with_name("call_TIE"); 974 PUSHSTACKi(PERLSI_MAGIC); 975 PUSHMARK(SP); 976 EXTEND(SP,(I32)items); 977 while (items--) 978 PUSHs(*MARK++); 979 PUTBACK; 980 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); 981 } 982 SPAGAIN; 983 984 sv = TOPs; 985 POPSTACK; 986 if (sv_isobject(sv)) { 987 sv_unmagic(varsv, how); 988 /* Croak if a self-tie on an aggregate is attempted. */ 989 if (varsv == SvRV(sv) && 990 (SvTYPE(varsv) == SVt_PVAV || 991 SvTYPE(varsv) == SVt_PVHV)) 992 Perl_croak(aTHX_ 993 "Self-ties of arrays and hashes are not supported"); 994 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0); 995 } 996 LEAVE_with_name("call_TIE"); 997 SP = PL_stack_base + markoff; 998 PUSHs(sv); 999 RETURN; 1000 } 1001 1002 1003 /* also used for: pp_dbmclose() */ 1004 1005 PP(pp_untie) 1006 { 1007 dSP; 1008 MAGIC *mg; 1009 SV *sv = POPs; 1010 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) 1011 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; 1012 1013 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) 1014 RETPUSHYES; 1015 1016 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && 1017 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; 1018 1019 if ((mg = SvTIED_mg(sv, how))) { 1020 SV * const obj = SvRV(SvTIED_obj(sv, mg)); 1021 if (obj && SvSTASH(obj)) { 1022 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); 1023 CV *cv; 1024 if (gv && isGV(gv) && (cv = GvCV(gv))) { 1025 PUSHMARK(SP); 1026 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); 1027 mXPUSHi(SvREFCNT(obj) - 1); 1028 PUTBACK; 1029 ENTER_with_name("call_UNTIE"); 1030 call_sv(MUTABLE_SV(cv), G_VOID); 1031 LEAVE_with_name("call_UNTIE"); 1032 SPAGAIN; 1033 } 1034 else if (mg && SvREFCNT(obj) > 1) { 1035 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE), 1036 "untie attempted while %" UVuf " inner references still exist", 1037 (UV)SvREFCNT(obj) - 1 ) ; 1038 } 1039 } 1040 } 1041 sv_unmagic(sv, how) ; 1042 1043 if (SvTYPE(sv) == SVt_PVHV) { 1044 /* If the tied hash was partway through iteration, free the iterator and 1045 * any key that it is pointing to. */ 1046 HE *entry; 1047 if (HvLAZYDEL(sv) && (entry = HvEITER_get((HV *)sv))) { 1048 HvLAZYDEL_off(sv); 1049 hv_free_ent(NULL, entry); 1050 HvEITER_set(MUTABLE_HV(sv), 0); 1051 } 1052 } 1053 1054 RETPUSHYES; 1055 } 1056 1057 PP(pp_tied) 1058 { 1059 dSP; 1060 const MAGIC *mg; 1061 dTOPss; 1062 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) 1063 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; 1064 1065 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) 1066 goto ret_undef; 1067 1068 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && 1069 !(sv = defelem_target(sv, NULL))) goto ret_undef; 1070 1071 if ((mg = SvTIED_mg(sv, how))) { 1072 SETs(SvTIED_obj(sv, mg)); 1073 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */ 1074 } 1075 ret_undef: 1076 SETs(&PL_sv_undef); 1077 return NORMAL; 1078 } 1079 1080 PP(pp_dbmopen) 1081 { 1082 dSP; 1083 dPOPPOPssrl; 1084 HV* stash; 1085 GV *gv = NULL; 1086 1087 HV * const hv = MUTABLE_HV(POPs); 1088 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP); 1089 stash = gv_stashsv(sv, 0); 1090 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { 1091 PUTBACK; 1092 require_pv("AnyDBM_File.pm"); 1093 SPAGAIN; 1094 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) 1095 DIE(aTHX_ "No dbm on this machine"); 1096 } 1097 1098 ENTER; 1099 PUSHMARK(SP); 1100 1101 EXTEND(SP, 5); 1102 PUSHs(sv); 1103 PUSHs(left); 1104 if (SvIV(right)) 1105 mPUSHu(O_RDWR|O_CREAT); 1106 else 1107 { 1108 mPUSHu(O_RDWR); 1109 if (!SvOK(right)) right = &PL_sv_no; 1110 } 1111 PUSHs(right); 1112 PUTBACK; 1113 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); 1114 SPAGAIN; 1115 1116 if (!sv_isobject(TOPs)) { 1117 SP--; 1118 PUSHMARK(SP); 1119 PUSHs(sv); 1120 PUSHs(left); 1121 mPUSHu(O_RDONLY); 1122 PUSHs(right); 1123 PUTBACK; 1124 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); 1125 SPAGAIN; 1126 if (sv_isobject(TOPs)) 1127 goto retie; 1128 } 1129 else { 1130 retie: 1131 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied); 1132 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0); 1133 } 1134 LEAVE; 1135 RETURN; 1136 } 1137 1138 PP(pp_sselect) 1139 { 1140 #ifdef HAS_SELECT 1141 dSP; dTARGET; 1142 I32 i; 1143 I32 j; 1144 char *s; 1145 SV *sv; 1146 NV value; 1147 I32 maxlen = 0; 1148 I32 nfound; 1149 struct timeval timebuf; 1150 struct timeval *tbuf = &timebuf; 1151 I32 growsize; 1152 char *fd_sets[4]; 1153 SV *svs[4]; 1154 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1155 I32 masksize; 1156 I32 offset; 1157 I32 k; 1158 1159 # if BYTEORDER & 0xf0000 1160 # define ORDERBYTE (0x88888888 - BYTEORDER) 1161 # else 1162 # define ORDERBYTE (0x4444 - BYTEORDER) 1163 # endif 1164 1165 #endif 1166 1167 SP -= 4; 1168 for (i = 1; i <= 3; i++) { 1169 SV * const sv = svs[i] = SP[i]; 1170 SvGETMAGIC(sv); 1171 if (!SvOK(sv)) 1172 continue; 1173 if (SvREADONLY(sv)) { 1174 if (!(SvPOK(sv) && SvCUR(sv) == 0)) 1175 Perl_croak_no_modify(); 1176 } 1177 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); 1178 if (SvPOK(sv)) { 1179 if (SvUTF8(sv)) sv_utf8_downgrade(sv, FALSE); 1180 } 1181 else { 1182 if (!SvPOKp(sv)) 1183 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 1184 "Non-string passed as bitmask"); 1185 if (SvGAMAGIC(sv)) { 1186 svs[i] = sv_newmortal(); 1187 sv_copypv_nomg(svs[i], sv); 1188 } 1189 else 1190 SvPV_force_nomg_nolen(sv); /* force string conversion */ 1191 } 1192 j = SvCUR(svs[i]); 1193 if (maxlen < j) 1194 maxlen = j; 1195 } 1196 1197 /* little endians can use vecs directly */ 1198 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1199 # ifdef NFDBITS 1200 1201 # ifndef NBBY 1202 # define NBBY 8 1203 # endif 1204 1205 masksize = NFDBITS / NBBY; 1206 # else 1207 masksize = sizeof(long); /* documented int, everyone seems to use long */ 1208 # endif 1209 Zero(&fd_sets[0], 4, char*); 1210 #endif 1211 1212 # if SELECT_MIN_BITS == 1 1213 growsize = sizeof(fd_set); 1214 # else 1215 # if defined(__GLIBC__) && defined(__FD_SETSIZE) 1216 # undef SELECT_MIN_BITS 1217 # define SELECT_MIN_BITS __FD_SETSIZE 1218 # endif 1219 /* If SELECT_MIN_BITS is greater than one we most probably will want 1220 * to align the sizes with SELECT_MIN_BITS/8 because for example 1221 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital 1222 * UNIX, Solaris, Darwin) the smallest quantum select() operates 1223 * on (sets/tests/clears bits) is 32 bits. */ 1224 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); 1225 # endif 1226 1227 sv = SP[4]; 1228 SvGETMAGIC(sv); 1229 if (SvOK(sv)) { 1230 value = SvNV_nomg(sv); 1231 if (value < 0.0) 1232 value = 0.0; 1233 timebuf.tv_sec = (long)value; 1234 value -= (NV)timebuf.tv_sec; 1235 timebuf.tv_usec = (long)(value * 1000000.0); 1236 } 1237 else 1238 tbuf = NULL; 1239 1240 for (i = 1; i <= 3; i++) { 1241 sv = svs[i]; 1242 if (!SvOK(sv) || SvCUR(sv) == 0) { 1243 fd_sets[i] = 0; 1244 continue; 1245 } 1246 assert(SvPOK(sv)); 1247 j = SvLEN(sv); 1248 if (j < growsize) { 1249 Sv_Grow(sv, growsize); 1250 } 1251 j = SvCUR(sv); 1252 s = SvPVX(sv) + j; 1253 while (++j <= growsize) { 1254 *s++ = '\0'; 1255 } 1256 1257 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1258 s = SvPVX(sv); 1259 Newx(fd_sets[i], growsize, char); 1260 for (offset = 0; offset < growsize; offset += masksize) { 1261 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) 1262 fd_sets[i][j+offset] = s[(k % masksize) + offset]; 1263 } 1264 #else 1265 fd_sets[i] = SvPVX(sv); 1266 #endif 1267 } 1268 1269 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST 1270 /* Can't make just the (void*) conditional because that would be 1271 * cpp #if within cpp macro, and not all compilers like that. */ 1272 nfound = PerlSock_select( 1273 maxlen * 8, 1274 (Select_fd_set_t) fd_sets[1], 1275 (Select_fd_set_t) fd_sets[2], 1276 (Select_fd_set_t) fd_sets[3], 1277 (void*) tbuf); /* Workaround for compiler bug. */ 1278 #else 1279 nfound = PerlSock_select( 1280 maxlen * 8, 1281 (Select_fd_set_t) fd_sets[1], 1282 (Select_fd_set_t) fd_sets[2], 1283 (Select_fd_set_t) fd_sets[3], 1284 tbuf); 1285 #endif 1286 for (i = 1; i <= 3; i++) { 1287 if (fd_sets[i]) { 1288 sv = svs[i]; 1289 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1290 s = SvPVX(sv); 1291 for (offset = 0; offset < growsize; offset += masksize) { 1292 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) 1293 s[(k % masksize) + offset] = fd_sets[i][j+offset]; 1294 } 1295 Safefree(fd_sets[i]); 1296 #endif 1297 if (sv != SP[i]) 1298 SvSetMagicSV(SP[i], sv); 1299 else 1300 SvSETMAGIC(sv); 1301 } 1302 } 1303 1304 PUSHi(nfound); 1305 if (GIMME_V == G_LIST && tbuf) { 1306 value = (NV)(timebuf.tv_sec) + 1307 (NV)(timebuf.tv_usec) / 1000000.0; 1308 mPUSHn(value); 1309 } 1310 RETURN; 1311 #else 1312 DIE(aTHX_ "select not implemented"); 1313 #endif 1314 } 1315 1316 /* 1317 1318 =for apidoc_section $GV 1319 1320 =for apidoc setdefout 1321 1322 Sets C<PL_defoutgv>, the default file handle for output, to the passed in 1323 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference 1324 count of the passed in typeglob is increased by one, and the reference count 1325 of the typeglob that C<PL_defoutgv> points to is decreased by one. 1326 1327 =for apidoc AmnU||PL_defoutgv 1328 1329 See C<L</setdefout>>. 1330 1331 =cut 1332 */ 1333 1334 void 1335 Perl_setdefout(pTHX_ GV *gv) 1336 { 1337 GV *oldgv = PL_defoutgv; 1338 1339 PERL_ARGS_ASSERT_SETDEFOUT; 1340 1341 SvREFCNT_inc_simple_void_NN(gv); 1342 PL_defoutgv = gv; 1343 SvREFCNT_dec(oldgv); 1344 } 1345 1346 PP(pp_select) 1347 { 1348 dSP; dTARGET; 1349 HV *hv; 1350 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; 1351 GV * egv = GvEGVx(PL_defoutgv); 1352 GV * const *gvp; 1353 1354 if (!egv) 1355 egv = PL_defoutgv; 1356 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL; 1357 gvp = hv && HvHasENAME(hv) 1358 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE) 1359 : NULL; 1360 if (gvp && *gvp == egv) { 1361 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); 1362 XPUSHTARG; 1363 } 1364 else { 1365 mXPUSHs(newRV(MUTABLE_SV(egv))); 1366 } 1367 1368 if (newdefout) { 1369 if (!GvIO(newdefout)) 1370 gv_IOadd(newdefout); 1371 setdefout(newdefout); 1372 } 1373 1374 RETURN; 1375 } 1376 1377 PP(pp_getc) 1378 { 1379 dSP; dTARGET; 1380 /* pp_coreargs pushes a NULL to indicate no args passed to 1381 * CORE::getc() */ 1382 GV * const gv = 1383 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); 1384 IO *const io = GvIO(gv); 1385 1386 if (MAXARG == 0) 1387 EXTEND(SP, 1); 1388 1389 if (io) { 1390 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 1391 if (mg) { 1392 const U8 gimme = GIMME_V; 1393 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0); 1394 if (gimme == G_SCALAR) { 1395 SPAGAIN; 1396 SvSetMagicSV_nosteal(TARG, TOPs); 1397 } 1398 return NORMAL; 1399 } 1400 } 1401 if (!gv || do_eof(gv)) { /* make sure we have fp with something */ 1402 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) 1403 report_evil_fh(gv); 1404 SETERRNO(EBADF,RMS_IFI); 1405 RETPUSHUNDEF; 1406 } 1407 TAINT; 1408 sv_setpvs(TARG, " "); 1409 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ 1410 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) { 1411 /* Find out how many bytes the char needs */ 1412 Size_t len = UTF8SKIP(SvPVX_const(TARG)); 1413 if (len > 1) { 1414 SvGROW(TARG,len+1); 1415 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); 1416 SvCUR_set(TARG,1+len); 1417 } 1418 SvUTF8_on(TARG); 1419 } 1420 else SvUTF8_off(TARG); 1421 PUSHTARG; 1422 RETURN; 1423 } 1424 1425 STATIC OP * 1426 S_doform(pTHX_ CV *cv, GV *gv, OP *retop) 1427 { 1428 PERL_CONTEXT *cx; 1429 const U8 gimme = GIMME_V; 1430 1431 PERL_ARGS_ASSERT_DOFORM; 1432 1433 if (CvCLONE(cv)) 1434 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); 1435 1436 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix); 1437 cx_pushformat(cx, cv, retop, gv); 1438 if (CvDEPTH(cv) >= 2) 1439 pad_push(CvPADLIST(cv), CvDEPTH(cv)); 1440 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); 1441 1442 setdefout(gv); /* locally select filehandle so $% et al work */ 1443 return CvSTART(cv); 1444 } 1445 1446 PP(pp_enterwrite) 1447 { 1448 dSP; 1449 GV *gv; 1450 IO *io; 1451 GV *fgv; 1452 CV *cv = NULL; 1453 1454 if (MAXARG == 0) { 1455 EXTEND(SP, 1); 1456 gv = PL_defoutgv; 1457 } 1458 else { 1459 gv = MUTABLE_GV(POPs); 1460 if (!gv) 1461 gv = PL_defoutgv; 1462 } 1463 io = GvIO(gv); 1464 if (!io) { 1465 RETPUSHNO; 1466 } 1467 if (IoFMT_GV(io)) 1468 fgv = IoFMT_GV(io); 1469 else 1470 fgv = gv; 1471 1472 assert(fgv); 1473 1474 cv = GvFORM(fgv); 1475 if (!cv) { 1476 SV * const tmpsv = sv_newmortal(); 1477 gv_efullname4(tmpsv, fgv, NULL, FALSE); 1478 DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv)); 1479 } 1480 IoFLAGS(io) &= ~IOf_DIDTOP; 1481 RETURNOP(doform(cv,gv,PL_op->op_next)); 1482 } 1483 1484 PP(pp_leavewrite) 1485 { 1486 dSP; 1487 GV * const gv = CX_CUR()->blk_format.gv; 1488 IO * const io = GvIOp(gv); 1489 PerlIO *ofp; 1490 PerlIO *fp; 1491 PERL_CONTEXT *cx; 1492 OP *retop; 1493 bool is_return = cBOOL(PL_op->op_type == OP_RETURN); 1494 1495 if (is_return || !io || !(ofp = IoOFP(io))) 1496 goto forget_top; 1497 1498 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", 1499 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); 1500 1501 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) && 1502 PL_formtarget != PL_toptarget) 1503 { 1504 GV *fgv; 1505 CV *cv; 1506 if (!IoTOP_GV(io)) { 1507 GV *topgv; 1508 1509 if (!IoTOP_NAME(io)) { 1510 SV *topname; 1511 if (!IoFMT_NAME(io)) 1512 IoFMT_NAME(io) = savepv(GvNAME(gv)); 1513 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP", 1514 HEKfARG(GvNAME_HEK(gv)))); 1515 topgv = gv_fetchsv(topname, 0, SVt_PVFM); 1516 if ((topgv && GvFORM(topgv)) || 1517 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM)) 1518 IoTOP_NAME(io) = savesvpv(topname); 1519 else 1520 IoTOP_NAME(io) = savepvs("top"); 1521 } 1522 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM); 1523 if (!topgv || !GvFORM(topgv)) { 1524 IoLINES_LEFT(io) = IoPAGE_LEN(io); 1525 goto forget_top; 1526 } 1527 IoTOP_GV(io) = topgv; 1528 } 1529 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ 1530 I32 lines = IoLINES_LEFT(io); 1531 const char *s = SvPVX_const(PL_formtarget); 1532 const char *e = SvEND(PL_formtarget); 1533 if (lines <= 0) /* Yow, header didn't even fit!!! */ 1534 goto forget_top; 1535 while (lines-- > 0) { 1536 s = (char *) memchr(s, '\n', e - s); 1537 if (!s) 1538 break; 1539 s++; 1540 } 1541 if (s) { 1542 const STRLEN save = SvCUR(PL_formtarget); 1543 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget)); 1544 do_print(PL_formtarget, ofp); 1545 SvCUR_set(PL_formtarget, save); 1546 sv_chop(PL_formtarget, s); 1547 FmLINES(PL_formtarget) -= IoLINES_LEFT(io); 1548 } 1549 } 1550 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) 1551 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp); 1552 IoLINES_LEFT(io) = IoPAGE_LEN(io); 1553 IoPAGE(io)++; 1554 PL_formtarget = PL_toptarget; 1555 IoFLAGS(io) |= IOf_DIDTOP; 1556 fgv = IoTOP_GV(io); 1557 assert(fgv); /* IoTOP_GV(io) should have been set above */ 1558 cv = GvFORM(fgv); 1559 if (!cv) { 1560 SV * const sv = sv_newmortal(); 1561 gv_efullname4(sv, fgv, NULL, FALSE); 1562 DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv)); 1563 } 1564 return doform(cv, gv, PL_op); 1565 } 1566 1567 forget_top: 1568 cx = CX_CUR(); 1569 assert(CxTYPE(cx) == CXt_FORMAT); 1570 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */ 1571 CX_LEAVE_SCOPE(cx); 1572 cx_popformat(cx); 1573 cx_popblock(cx); 1574 retop = cx->blk_sub.retop; 1575 CX_POP(cx); 1576 1577 EXTEND(SP, 1); 1578 1579 if (is_return) 1580 /* XXX the semantics of doing 'return' in a format aren't documented. 1581 * Currently we ignore any args to 'return' and just return 1582 * a single undef in both scalar and list contexts 1583 */ 1584 PUSHs(&PL_sv_undef); 1585 else if (!io || !(fp = IoOFP(io))) { 1586 if (io && IoIFP(io)) 1587 report_wrongway_fh(gv, '<'); 1588 else 1589 report_evil_fh(gv); 1590 PUSHs(&PL_sv_no); 1591 } 1592 else { 1593 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { 1594 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow"); 1595 } 1596 if (!do_print(PL_formtarget, fp)) 1597 PUSHs(&PL_sv_no); 1598 else { 1599 FmLINES(PL_formtarget) = 0; 1600 SvCUR_set(PL_formtarget, 0); 1601 *SvEND(PL_formtarget) = '\0'; 1602 if (IoFLAGS(io) & IOf_FLUSH) 1603 (void)PerlIO_flush(fp); 1604 PUSHs(&PL_sv_yes); 1605 } 1606 } 1607 PL_formtarget = PL_bodytarget; 1608 RETURNOP(retop); 1609 } 1610 1611 PP(pp_prtf) 1612 { 1613 dSP; dMARK; dORIGMARK; 1614 PerlIO *fp; 1615 1616 GV * const gv 1617 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; 1618 IO *const io = GvIO(gv); 1619 1620 /* Treat empty list as "" */ 1621 if (MARK == SP) XPUSHs(&PL_sv_no); 1622 1623 if (io) { 1624 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 1625 if (mg) { 1626 if (MARK == ORIGMARK) { 1627 MEXTEND(SP, 1); 1628 ++MARK; 1629 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); 1630 ++SP; 1631 } 1632 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io), 1633 mg, 1634 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, 1635 sp - mark); 1636 } 1637 } 1638 1639 if (!io) { 1640 report_evil_fh(gv); 1641 SETERRNO(EBADF,RMS_IFI); 1642 goto just_say_no; 1643 } 1644 else if (!(fp = IoOFP(io))) { 1645 if (IoIFP(io)) 1646 report_wrongway_fh(gv, '<'); 1647 else if (ckWARN(WARN_CLOSED)) 1648 report_evil_fh(gv); 1649 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); 1650 goto just_say_no; 1651 } 1652 else { 1653 SV *sv = sv_newmortal(); 1654 do_sprintf(sv, SP - MARK, MARK + 1); 1655 if (!do_print(sv, fp)) 1656 goto just_say_no; 1657 1658 if (IoFLAGS(io) & IOf_FLUSH) 1659 if (PerlIO_flush(fp) == EOF) 1660 goto just_say_no; 1661 } 1662 SP = ORIGMARK; 1663 PUSHs(&PL_sv_yes); 1664 RETURN; 1665 1666 just_say_no: 1667 SP = ORIGMARK; 1668 PUSHs(&PL_sv_undef); 1669 RETURN; 1670 } 1671 1672 PP(pp_sysopen) 1673 { 1674 dSP; 1675 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; 1676 const int mode = POPi; 1677 SV * const sv = POPs; 1678 GV * const gv = MUTABLE_GV(POPs); 1679 STRLEN len; 1680 1681 /* Need TIEHANDLE method ? */ 1682 const char * const tmps = SvPV_const(sv, len); 1683 if (do_open_raw(gv, tmps, len, mode, perm, NULL)) { 1684 IoLINES(GvIOp(gv)) = 0; 1685 PUSHs(&PL_sv_yes); 1686 } 1687 else { 1688 PUSHs(&PL_sv_undef); 1689 } 1690 RETURN; 1691 } 1692 1693 1694 /* also used for: pp_read() and pp_recv() (where supported) */ 1695 1696 PP(pp_sysread) 1697 { 1698 dSP; dMARK; dORIGMARK; dTARGET; 1699 SSize_t offset; 1700 IO *io; 1701 char *buffer; 1702 STRLEN orig_size; 1703 SSize_t length; 1704 SSize_t count; 1705 SV *bufsv; 1706 STRLEN blen; 1707 int fp_utf8; 1708 int buffer_utf8; 1709 SV *read_target; 1710 Size_t got = 0; 1711 Size_t wanted; 1712 bool charstart = FALSE; 1713 STRLEN charskip = 0; 1714 STRLEN skip = 0; 1715 GV * const gv = MUTABLE_GV(*++MARK); 1716 int fd; 1717 1718 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) 1719 && gv && (io = GvIO(gv)) ) 1720 { 1721 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 1722 if (mg) { 1723 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg, 1724 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, 1725 sp - mark); 1726 } 1727 } 1728 1729 if (!gv) 1730 goto say_undef; 1731 bufsv = *++MARK; 1732 if (! SvOK(bufsv)) 1733 SvPVCLEAR(bufsv); 1734 length = SvIVx(*++MARK); 1735 if (length < 0) 1736 DIE(aTHX_ "Negative length"); 1737 SETERRNO(0,0); 1738 if (MARK < SP) 1739 offset = SvIVx(*++MARK); 1740 else 1741 offset = 0; 1742 io = GvIO(gv); 1743 if (!io || !IoIFP(io)) { 1744 report_evil_fh(gv); 1745 SETERRNO(EBADF,RMS_IFI); 1746 goto say_undef; 1747 } 1748 1749 /* Note that fd can here validly be -1, don't check it yet. */ 1750 fd = PerlIO_fileno(IoIFP(io)); 1751 1752 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { 1753 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) { 1754 Perl_croak(aTHX_ 1755 "%s() isn't allowed on :utf8 handles", 1756 OP_DESC(PL_op)); 1757 } 1758 buffer = SvPVutf8_force(bufsv, blen); 1759 /* UTF-8 may not have been set if they are all low bytes */ 1760 SvUTF8_on(bufsv); 1761 buffer_utf8 = 0; 1762 } 1763 else { 1764 buffer = SvPV_force(bufsv, blen); 1765 buffer_utf8 = DO_UTF8(bufsv); 1766 } 1767 if (DO_UTF8(bufsv)) { 1768 blen = sv_len_utf8_nomg(bufsv); 1769 } 1770 1771 charstart = TRUE; 1772 charskip = 0; 1773 skip = 0; 1774 wanted = length; 1775 1776 #ifdef HAS_SOCKET 1777 if (PL_op->op_type == OP_RECV) { 1778 Sock_size_t bufsize; 1779 char namebuf[MAXPATHLEN]; 1780 if (fd < 0) { 1781 SETERRNO(EBADF,SS_IVCHAN); 1782 goto say_undef; 1783 } 1784 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) 1785 bufsize = sizeof (struct sockaddr_in); 1786 #else 1787 bufsize = sizeof namebuf; 1788 #endif 1789 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */ 1790 if (bufsize >= 256) 1791 bufsize = 255; 1792 #endif 1793 buffer = SvGROW(bufsv, (STRLEN)(length+1)); 1794 /* 'offset' means 'flags' here */ 1795 count = PerlSock_recvfrom(fd, buffer, length, offset, 1796 (struct sockaddr *)namebuf, &bufsize); 1797 if (count < 0) 1798 goto say_undef; 1799 /* MSG_TRUNC can give oversized count; quietly lose it */ 1800 if (count > length) 1801 count = length; 1802 SvCUR_set(bufsv, count); 1803 *SvEND(bufsv) = '\0'; 1804 (void)SvPOK_only(bufsv); 1805 if (fp_utf8) 1806 SvUTF8_on(bufsv); 1807 SvSETMAGIC(bufsv); 1808 /* This should not be marked tainted if the fp is marked clean */ 1809 if (!(IoFLAGS(io) & IOf_UNTAINT)) 1810 SvTAINTED_on(bufsv); 1811 SP = ORIGMARK; 1812 #if defined(__CYGWIN__) 1813 /* recvfrom() on cygwin doesn't set bufsize at all for 1814 connected sockets, leaving us with trash in the returned 1815 name, so use the same test as the Win32 code to check if it 1816 wasn't set, and set it [perl #118843] */ 1817 if (bufsize == sizeof namebuf) 1818 bufsize = 0; 1819 #endif 1820 sv_setpvn(TARG, namebuf, bufsize); 1821 PUSHs(TARG); 1822 RETURN; 1823 } 1824 #endif 1825 if (offset < 0) { 1826 if (-offset > (SSize_t)blen) 1827 DIE(aTHX_ "Offset outside string"); 1828 offset += blen; 1829 } 1830 if (DO_UTF8(bufsv)) { 1831 /* convert offset-as-chars to offset-as-bytes */ 1832 if (offset >= (SSize_t)blen) 1833 offset += SvCUR(bufsv) - blen; 1834 else 1835 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; 1836 } 1837 1838 more_bytes: 1839 /* Reestablish the fd in case it shifted from underneath us. */ 1840 fd = PerlIO_fileno(IoIFP(io)); 1841 1842 orig_size = SvCUR(bufsv); 1843 /* Allocating length + offset + 1 isn't perfect in the case of reading 1844 bytes from a byte file handle into a UTF8 buffer, but it won't harm us 1845 unduly. 1846 (should be 2 * length + offset + 1, or possibly something longer if 1847 IN_ENCODING Is true) */ 1848 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); 1849 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */ 1850 Zero(buffer+orig_size, offset-orig_size, char); 1851 } 1852 buffer = buffer + offset; 1853 if (!buffer_utf8) { 1854 read_target = bufsv; 1855 } else { 1856 /* Best to read the bytes into a new SV, upgrade that to UTF8, then 1857 concatenate it to the current buffer. */ 1858 1859 /* Truncate the existing buffer to the start of where we will be 1860 reading to: */ 1861 SvCUR_set(bufsv, offset); 1862 1863 read_target = newSV_type_mortal(SVt_PV); 1864 buffer = sv_grow_fresh(read_target, (STRLEN)(length + 1)); 1865 } 1866 1867 if (PL_op->op_type == OP_SYSREAD) { 1868 #ifdef PERL_SOCK_SYSREAD_IS_RECV 1869 if (IoTYPE(io) == IoTYPE_SOCKET) { 1870 if (fd < 0) { 1871 SETERRNO(EBADF,SS_IVCHAN); 1872 count = -1; 1873 } 1874 else 1875 count = PerlSock_recv(fd, buffer, length, 0); 1876 } 1877 else 1878 #endif 1879 { 1880 if (fd < 0) { 1881 SETERRNO(EBADF,RMS_IFI); 1882 count = -1; 1883 } 1884 else 1885 count = PerlLIO_read(fd, buffer, length); 1886 } 1887 } 1888 else 1889 { 1890 count = PerlIO_read(IoIFP(io), buffer, length); 1891 /* PerlIO_read() - like fread() returns 0 on both error and EOF */ 1892 if (count == 0 && PerlIO_error(IoIFP(io))) 1893 count = -1; 1894 } 1895 if (count < 0) { 1896 if (IoTYPE(io) == IoTYPE_WRONLY) 1897 report_wrongway_fh(gv, '>'); 1898 goto say_undef; 1899 } 1900 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); 1901 *SvEND(read_target) = '\0'; 1902 (void)SvPOK_only(read_target); 1903 if (fp_utf8 && !IN_BYTES) { 1904 /* Look at utf8 we got back and count the characters */ 1905 const char *bend = buffer + count; 1906 while (buffer < bend) { 1907 if (charstart) { 1908 skip = UTF8SKIP(buffer); 1909 charskip = 0; 1910 } 1911 if (buffer - charskip + skip > bend) { 1912 /* partial character - try for rest of it */ 1913 length = skip - (bend-buffer); 1914 offset = bend - SvPVX_const(bufsv); 1915 charstart = FALSE; 1916 charskip += count; 1917 goto more_bytes; 1918 } 1919 else { 1920 got++; 1921 buffer += skip; 1922 charstart = TRUE; 1923 charskip = 0; 1924 } 1925 } 1926 /* If we have not 'got' the number of _characters_ we 'wanted' get some more 1927 provided amount read (count) was what was requested (length) 1928 */ 1929 if (got < wanted && count == length) { 1930 length = wanted - got; 1931 offset = bend - SvPVX_const(bufsv); 1932 goto more_bytes; 1933 } 1934 /* return value is character count */ 1935 count = got; 1936 SvUTF8_on(bufsv); 1937 } 1938 else if (buffer_utf8) { 1939 /* Let svcatsv upgrade the bytes we read in to utf8. 1940 The buffer is a mortal so will be freed soon. */ 1941 sv_catsv_nomg(bufsv, read_target); 1942 } 1943 SvSETMAGIC(bufsv); 1944 /* This should not be marked tainted if the fp is marked clean */ 1945 if (!(IoFLAGS(io) & IOf_UNTAINT)) 1946 SvTAINTED_on(bufsv); 1947 SP = ORIGMARK; 1948 PUSHi(count); 1949 RETURN; 1950 1951 say_undef: 1952 SP = ORIGMARK; 1953 RETPUSHUNDEF; 1954 } 1955 1956 1957 /* also used for: pp_send() where defined */ 1958 1959 PP(pp_syswrite) 1960 { 1961 dSP; dMARK; dORIGMARK; dTARGET; 1962 SV *bufsv; 1963 const char *buffer; 1964 SSize_t retval; 1965 STRLEN blen; 1966 const int op_type = PL_op->op_type; 1967 bool doing_utf8; 1968 U8 *tmpbuf = NULL; 1969 GV *const gv = MUTABLE_GV(*++MARK); 1970 IO *const io = GvIO(gv); 1971 int fd; 1972 1973 if (op_type == OP_SYSWRITE && io) { 1974 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 1975 if (mg) { 1976 if (MARK == SP - 1) { 1977 SV *sv = *SP; 1978 mXPUSHi(sv_len(sv)); 1979 PUTBACK; 1980 } 1981 1982 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg, 1983 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, 1984 sp - mark); 1985 } 1986 } 1987 if (!gv) 1988 goto say_undef; 1989 1990 bufsv = *++MARK; 1991 1992 SETERRNO(0,0); 1993 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) { 1994 retval = -1; 1995 if (io && IoIFP(io)) 1996 report_wrongway_fh(gv, '<'); 1997 else 1998 report_evil_fh(gv); 1999 SETERRNO(EBADF,RMS_IFI); 2000 goto say_undef; 2001 } 2002 fd = PerlIO_fileno(IoIFP(io)); 2003 if (fd < 0) { 2004 SETERRNO(EBADF,SS_IVCHAN); 2005 retval = -1; 2006 goto say_undef; 2007 } 2008 2009 /* Do this first to trigger any overloading. */ 2010 buffer = SvPV_const(bufsv, blen); 2011 doing_utf8 = DO_UTF8(bufsv); 2012 2013 if (PerlIO_isutf8(IoIFP(io))) { 2014 Perl_croak(aTHX_ 2015 "%s() isn't allowed on :utf8 handles", 2016 OP_DESC(PL_op)); 2017 } 2018 else if (doing_utf8) { 2019 STRLEN tmplen = blen; 2020 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8); 2021 if (!doing_utf8) { 2022 tmpbuf = result; 2023 buffer = (char *) tmpbuf; 2024 blen = tmplen; 2025 } 2026 else { 2027 assert((char *)result == buffer); 2028 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op)); 2029 } 2030 } 2031 2032 #ifdef HAS_SOCKET 2033 if (op_type == OP_SEND) { 2034 const int flags = SvIVx(*++MARK); 2035 if (SP > MARK) { 2036 STRLEN mlen; 2037 char * const sockbuf = SvPVx(*++MARK, mlen); 2038 retval = PerlSock_sendto(fd, buffer, blen, 2039 flags, (struct sockaddr *)sockbuf, mlen); 2040 } 2041 else { 2042 retval = PerlSock_send(fd, buffer, blen, flags); 2043 } 2044 } 2045 else 2046 #endif 2047 { 2048 Size_t length = 0; /* This length is in characters. */ 2049 IV offset; 2050 2051 if (MARK >= SP) { 2052 length = blen; 2053 } else { 2054 #if Size_t_size > IVSIZE 2055 length = (Size_t)SvNVx(*++MARK); 2056 #else 2057 length = (Size_t)SvIVx(*++MARK); 2058 #endif 2059 if ((SSize_t)length < 0) { 2060 Safefree(tmpbuf); 2061 DIE(aTHX_ "Negative length"); 2062 } 2063 } 2064 2065 if (MARK < SP) { 2066 offset = SvIVx(*++MARK); 2067 if (offset < 0) { 2068 if (-offset > (IV)blen) { 2069 Safefree(tmpbuf); 2070 DIE(aTHX_ "Offset outside string"); 2071 } 2072 offset += blen; 2073 } else if (offset > (IV)blen) { 2074 Safefree(tmpbuf); 2075 DIE(aTHX_ "Offset outside string"); 2076 } 2077 } else 2078 offset = 0; 2079 if (length > blen - offset) 2080 length = blen - offset; 2081 buffer = buffer+offset; 2082 2083 #ifdef PERL_SOCK_SYSWRITE_IS_SEND 2084 if (IoTYPE(io) == IoTYPE_SOCKET) { 2085 retval = PerlSock_send(fd, buffer, length, 0); 2086 } 2087 else 2088 #endif 2089 { 2090 /* See the note at doio.c:do_print about filesize limits. --jhi */ 2091 retval = PerlLIO_write(fd, buffer, length); 2092 } 2093 } 2094 2095 if (retval < 0) 2096 goto say_undef; 2097 SP = ORIGMARK; 2098 2099 Safefree(tmpbuf); 2100 #if Size_t_size > IVSIZE 2101 PUSHn(retval); 2102 #else 2103 PUSHi(retval); 2104 #endif 2105 RETURN; 2106 2107 say_undef: 2108 Safefree(tmpbuf); 2109 SP = ORIGMARK; 2110 RETPUSHUNDEF; 2111 } 2112 2113 PP(pp_eof) 2114 { 2115 dSP; 2116 GV *gv; 2117 IO *io; 2118 const MAGIC *mg; 2119 /* 2120 * in Perl 5.12 and later, the additional parameter is a bitmask: 2121 * 0 = eof 2122 * 1 = eof(FH) 2123 * 2 = eof() <- ARGV magic 2124 * 2125 * I'll rely on the compiler's trace flow analysis to decide whether to 2126 * actually assign this out here, or punt it into the only block where it is 2127 * used. Doing it out here is DRY on the condition logic. 2128 */ 2129 unsigned int which; 2130 2131 if (MAXARG) { 2132 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */ 2133 which = 1; 2134 } 2135 else { 2136 EXTEND(SP, 1); 2137 2138 if (PL_op->op_flags & OPf_SPECIAL) { 2139 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */ 2140 which = 2; 2141 } 2142 else { 2143 gv = PL_last_in_gv; /* eof */ 2144 which = 0; 2145 } 2146 } 2147 2148 if (!gv) 2149 RETPUSHYES; 2150 2151 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { 2152 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); 2153 } 2154 2155 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ 2156 if (io && !IoIFP(io)) { 2157 if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) { 2158 SV ** svp; 2159 IoLINES(io) = 0; 2160 IoFLAGS(io) &= ~IOf_START; 2161 do_open6(gv, "-", 1, NULL, NULL, 0); 2162 svp = &GvSV(gv); 2163 if (*svp) { 2164 SV * sv = *svp; 2165 sv_setpvs(sv, "-"); 2166 SvSETMAGIC(sv); 2167 } 2168 else 2169 *svp = newSVpvs("-"); 2170 } 2171 else if (!nextargv(gv, FALSE)) 2172 RETPUSHYES; 2173 } 2174 } 2175 2176 PUSHs(boolSV(do_eof(gv))); 2177 RETURN; 2178 } 2179 2180 PP(pp_tell) 2181 { 2182 dSP; dTARGET; 2183 GV *gv; 2184 IO *io; 2185 2186 if (MAXARG != 0 && (TOPs || POPs)) 2187 PL_last_in_gv = MUTABLE_GV(POPs); 2188 else 2189 EXTEND(SP, 1); 2190 gv = PL_last_in_gv; 2191 2192 io = GvIO(gv); 2193 if (io) { 2194 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 2195 if (mg) { 2196 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg); 2197 } 2198 } 2199 else if (!gv) { 2200 if (!errno) 2201 SETERRNO(EBADF,RMS_IFI); 2202 PUSHi(-1); 2203 RETURN; 2204 } 2205 2206 #if LSEEKSIZE > IVSIZE 2207 PUSHn( (NV)do_tell(gv) ); 2208 #else 2209 PUSHi( (IV)do_tell(gv) ); 2210 #endif 2211 RETURN; 2212 } 2213 2214 2215 /* also used for: pp_seek() */ 2216 2217 PP(pp_sysseek) 2218 { 2219 dSP; 2220 const int whence = POPi; 2221 #if LSEEKSIZE > IVSIZE 2222 const Off_t offset = (Off_t)SvNVx(POPs); 2223 #else 2224 const Off_t offset = (Off_t)SvIVx(POPs); 2225 #endif 2226 2227 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs); 2228 IO *const io = GvIO(gv); 2229 2230 if (io) { 2231 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); 2232 if (mg) { 2233 #if LSEEKSIZE > IVSIZE 2234 SV *const offset_sv = newSVnv((NV) offset); 2235 #else 2236 SV *const offset_sv = newSViv(offset); 2237 #endif 2238 2239 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv, 2240 newSViv(whence)); 2241 } 2242 } 2243 2244 if (PL_op->op_type == OP_SEEK) 2245 PUSHs(boolSV(do_seek(gv, offset, whence))); 2246 else { 2247 const Off_t sought = do_sysseek(gv, offset, whence); 2248 if (sought < 0) 2249 PUSHs(&PL_sv_undef); 2250 else { 2251 SV* const sv = sought ? 2252 #if LSEEKSIZE > IVSIZE 2253 newSVnv((NV)sought) 2254 #else 2255 newSViv(sought) 2256 #endif 2257 : newSVpvn(zero_but_true, ZBTLEN); 2258 mPUSHs(sv); 2259 } 2260 } 2261 RETURN; 2262 } 2263 2264 PP(pp_truncate) 2265 { 2266 dSP; 2267 /* There seems to be no consensus on the length type of truncate() 2268 * and ftruncate(), both off_t and size_t have supporters. In 2269 * general one would think that when using large files, off_t is 2270 * at least as wide as size_t, so using an off_t should be okay. */ 2271 /* XXX Configure probe for the length type of *truncate() needed XXX */ 2272 Off_t len; 2273 2274 #if Off_t_size > IVSIZE 2275 len = (Off_t)POPn; 2276 #else 2277 len = (Off_t)POPi; 2278 #endif 2279 /* Checking for length < 0 is problematic as the type might or 2280 * might not be signed: if it is not, clever compilers will moan. */ 2281 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ 2282 SETERRNO(0,0); 2283 { 2284 SV * const sv = POPs; 2285 int result = 1; 2286 GV *tmpgv; 2287 IO *io; 2288 2289 if (PL_op->op_flags & OPf_SPECIAL 2290 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1) 2291 : cBOOL(tmpgv = MAYBE_DEREF_GV(sv)) ) 2292 { 2293 io = GvIO(tmpgv); 2294 if (!io) 2295 result = 0; 2296 else { 2297 PerlIO *fp; 2298 do_ftruncate_io: 2299 TAINT_PROPER("truncate"); 2300 if (!(fp = IoIFP(io))) { 2301 result = 0; 2302 } 2303 else { 2304 int fd = PerlIO_fileno(fp); 2305 if (fd < 0) { 2306 SETERRNO(EBADF,RMS_IFI); 2307 result = 0; 2308 } else { 2309 if (len < 0) { 2310 SETERRNO(EINVAL, LIB_INVARG); 2311 result = 0; 2312 } else { 2313 PerlIO_flush(fp); 2314 #ifdef HAS_TRUNCATE 2315 if (ftruncate(fd, len) < 0) 2316 #else 2317 if (my_chsize(fd, len) < 0) 2318 #endif 2319 result = 0; 2320 } 2321 } 2322 } 2323 } 2324 } 2325 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 2326 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */ 2327 goto do_ftruncate_io; 2328 } 2329 else { 2330 const char * const name = SvPV_nomg_const_nolen(sv); 2331 TAINT_PROPER("truncate"); 2332 #ifdef HAS_TRUNCATE 2333 if (truncate(name, len) < 0) 2334 result = 0; 2335 #else 2336 { 2337 int mode = O_RDWR; 2338 int tmpfd; 2339 2340 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) 2341 mode |= O_LARGEFILE; /* Transparently largefiley. */ 2342 #endif 2343 #ifdef O_BINARY 2344 /* On open(), the Win32 CRT tries to seek around text 2345 * files using 32-bit offsets, which causes the open() 2346 * to fail on large files, so open in binary mode. 2347 */ 2348 mode |= O_BINARY; 2349 #endif 2350 tmpfd = PerlLIO_open_cloexec(name, mode); 2351 2352 if (tmpfd < 0) { 2353 result = 0; 2354 } else { 2355 if (my_chsize(tmpfd, len) < 0) 2356 result = 0; 2357 PerlLIO_close(tmpfd); 2358 } 2359 } 2360 #endif 2361 } 2362 2363 if (result) 2364 RETPUSHYES; 2365 if (!errno) 2366 SETERRNO(EBADF,RMS_IFI); 2367 RETPUSHUNDEF; 2368 } 2369 } 2370 2371 2372 /* also used for: pp_fcntl() */ 2373 2374 PP(pp_ioctl) 2375 { 2376 dSP; dTARGET; 2377 SV * const argsv = POPs; 2378 const unsigned int func = POPu; 2379 int optype; 2380 GV * const gv = MUTABLE_GV(POPs); 2381 IO * const io = GvIOn(gv); 2382 char *s; 2383 IV retval; 2384 2385 if (!IoIFP(io)) { 2386 report_evil_fh(gv); 2387 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ 2388 RETPUSHUNDEF; 2389 } 2390 2391 if (SvPOK(argsv) || !SvNIOK(argsv)) { 2392 STRLEN len; 2393 STRLEN need; 2394 s = SvPV_force(argsv, len); 2395 need = IOCPARM_LEN(func); 2396 if (len < need) { 2397 s = Sv_Grow(argsv, need + 1); 2398 SvCUR_set(argsv, need); 2399 } 2400 2401 s[SvCUR(argsv)] = 17; /* a little sanity check here */ 2402 } 2403 else { 2404 retval = SvIV(argsv); 2405 s = INT2PTR(char*,retval); /* ouch */ 2406 } 2407 2408 optype = PL_op->op_type; 2409 TAINT_PROPER(PL_op_desc[optype]); 2410 2411 if (optype == OP_IOCTL) 2412 #ifdef HAS_IOCTL 2413 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s); 2414 #else 2415 DIE(aTHX_ "ioctl is not implemented"); 2416 #endif 2417 else 2418 #ifndef HAS_FCNTL 2419 DIE(aTHX_ "fcntl is not implemented"); 2420 #elif defined(OS2) && defined(__EMX__) 2421 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); 2422 #else 2423 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); 2424 #endif 2425 2426 #if defined(HAS_IOCTL) || defined(HAS_FCNTL) 2427 if (SvPOK(argsv)) { 2428 if (s[SvCUR(argsv)] != 17) 2429 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", 2430 OP_NAME(PL_op)); 2431 s[SvCUR(argsv)] = 0; /* put our null back */ 2432 SvSETMAGIC(argsv); /* Assume it has changed */ 2433 } 2434 2435 if (retval == -1) 2436 RETPUSHUNDEF; 2437 if (retval != 0) { 2438 PUSHi(retval); 2439 } 2440 else { 2441 PUSHp(zero_but_true, ZBTLEN); 2442 } 2443 #endif 2444 RETURN; 2445 } 2446 2447 PP(pp_flock) 2448 { 2449 #ifdef FLOCK 2450 dSP; dTARGET; 2451 I32 value; 2452 const int argtype = POPi; 2453 GV * const gv = MUTABLE_GV(POPs); 2454 IO *const io = GvIO(gv); 2455 PerlIO *const fp = io ? IoIFP(io) : NULL; 2456 2457 /* XXX Looks to me like io is always NULL at this point */ 2458 if (fp) { 2459 (void)PerlIO_flush(fp); 2460 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); 2461 } 2462 else { 2463 report_evil_fh(gv); 2464 value = 0; 2465 SETERRNO(EBADF,RMS_IFI); 2466 } 2467 PUSHi(value); 2468 RETURN; 2469 #else 2470 DIE(aTHX_ PL_no_func, "flock"); 2471 #endif 2472 } 2473 2474 /* Sockets. */ 2475 2476 #ifdef HAS_SOCKET 2477 2478 PP(pp_socket) 2479 { 2480 dSP; 2481 const int protocol = POPi; 2482 const int type = POPi; 2483 const int domain = POPi; 2484 GV * const gv = MUTABLE_GV(POPs); 2485 IO * const io = GvIOn(gv); 2486 int fd; 2487 2488 if (IoIFP(io)) 2489 do_close(gv, FALSE); 2490 2491 TAINT_PROPER("socket"); 2492 fd = PerlSock_socket_cloexec(domain, type, protocol); 2493 if (fd < 0) { 2494 RETPUSHUNDEF; 2495 } 2496 IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ 2497 IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE); 2498 IoTYPE(io) = IoTYPE_SOCKET; 2499 if (!IoIFP(io) || !IoOFP(io)) { 2500 if (IoIFP(io)) PerlIO_close(IoIFP(io)); 2501 if (IoOFP(io)) PerlIO_close(IoOFP(io)); 2502 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); 2503 RETPUSHUNDEF; 2504 } 2505 2506 RETPUSHYES; 2507 } 2508 #endif 2509 2510 PP(pp_sockpair) 2511 { 2512 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) 2513 dSP; 2514 int fd[2]; 2515 const int protocol = POPi; 2516 const int type = POPi; 2517 const int domain = POPi; 2518 2519 GV * const gv2 = MUTABLE_GV(POPs); 2520 IO * const io2 = GvIOn(gv2); 2521 GV * const gv1 = MUTABLE_GV(POPs); 2522 IO * const io1 = GvIOn(gv1); 2523 2524 if (IoIFP(io1)) 2525 do_close(gv1, FALSE); 2526 if (IoIFP(io2)) 2527 do_close(gv2, FALSE); 2528 2529 TAINT_PROPER("socketpair"); 2530 if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0) 2531 RETPUSHUNDEF; 2532 IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE); 2533 IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE); 2534 IoTYPE(io1) = IoTYPE_SOCKET; 2535 IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE); 2536 IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE); 2537 IoTYPE(io2) = IoTYPE_SOCKET; 2538 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { 2539 if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); 2540 if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); 2541 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]); 2542 if (IoIFP(io2)) PerlIO_close(IoIFP(io2)); 2543 if (IoOFP(io2)) PerlIO_close(IoOFP(io2)); 2544 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); 2545 RETPUSHUNDEF; 2546 } 2547 2548 RETPUSHYES; 2549 #else 2550 DIE(aTHX_ PL_no_sock_func, "socketpair"); 2551 #endif 2552 } 2553 2554 #ifdef HAS_SOCKET 2555 2556 /* also used for: pp_connect() */ 2557 2558 PP(pp_bind) 2559 { 2560 dSP; 2561 SV * const addrsv = POPs; 2562 /* OK, so on what platform does bind modify addr? */ 2563 const char *addr; 2564 GV * const gv = MUTABLE_GV(POPs); 2565 IO * const io = GvIOn(gv); 2566 STRLEN len; 2567 int op_type; 2568 int fd; 2569 2570 if (!IoIFP(io)) 2571 goto nuts; 2572 fd = PerlIO_fileno(IoIFP(io)); 2573 if (fd < 0) 2574 goto nuts; 2575 2576 addr = SvPV_const(addrsv, len); 2577 op_type = PL_op->op_type; 2578 TAINT_PROPER(PL_op_desc[op_type]); 2579 if ((op_type == OP_BIND 2580 ? PerlSock_bind(fd, (struct sockaddr *)addr, len) 2581 : PerlSock_connect(fd, (struct sockaddr *)addr, len)) 2582 >= 0) 2583 RETPUSHYES; 2584 else 2585 RETPUSHUNDEF; 2586 2587 nuts: 2588 report_evil_fh(gv); 2589 SETERRNO(EBADF,SS_IVCHAN); 2590 RETPUSHUNDEF; 2591 } 2592 2593 PP(pp_listen) 2594 { 2595 dSP; 2596 const int backlog = POPi; 2597 GV * const gv = MUTABLE_GV(POPs); 2598 IO * const io = GvIOn(gv); 2599 2600 if (!IoIFP(io)) 2601 goto nuts; 2602 2603 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) 2604 RETPUSHYES; 2605 else 2606 RETPUSHUNDEF; 2607 2608 nuts: 2609 report_evil_fh(gv); 2610 SETERRNO(EBADF,SS_IVCHAN); 2611 RETPUSHUNDEF; 2612 } 2613 2614 PP(pp_accept) 2615 { 2616 dSP; dTARGET; 2617 IO *nstio; 2618 char namebuf[MAXPATHLEN]; 2619 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) 2620 Sock_size_t len = sizeof (struct sockaddr_in); 2621 #else 2622 Sock_size_t len = sizeof namebuf; 2623 #endif 2624 GV * const ggv = MUTABLE_GV(POPs); 2625 GV * const ngv = MUTABLE_GV(POPs); 2626 int fd; 2627 2628 IO * const gstio = GvIO(ggv); 2629 if (!gstio || !IoIFP(gstio)) 2630 goto nuts; 2631 2632 nstio = GvIOn(ngv); 2633 fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); 2634 #if defined(OEMVS) 2635 if (len == 0) { 2636 /* Some platforms indicate zero length when an AF_UNIX client is 2637 * not bound. Simulate a non-zero-length sockaddr structure in 2638 * this case. */ 2639 namebuf[0] = 0; /* sun_len */ 2640 namebuf[1] = AF_UNIX; /* sun_family */ 2641 len = 2; 2642 } 2643 #endif 2644 2645 if (fd < 0) 2646 goto badexit; 2647 if (IoIFP(nstio)) 2648 do_close(ngv, FALSE); 2649 IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); 2650 IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE); 2651 IoTYPE(nstio) = IoTYPE_SOCKET; 2652 if (!IoIFP(nstio) || !IoOFP(nstio)) { 2653 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); 2654 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio)); 2655 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); 2656 goto badexit; 2657 } 2658 2659 #ifdef __SCO_VERSION__ 2660 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ 2661 #endif 2662 2663 PUSHp(namebuf, len); 2664 RETURN; 2665 2666 nuts: 2667 report_evil_fh(ggv); 2668 SETERRNO(EBADF,SS_IVCHAN); 2669 2670 badexit: 2671 RETPUSHUNDEF; 2672 2673 } 2674 2675 PP(pp_shutdown) 2676 { 2677 dSP; dTARGET; 2678 const int how = POPi; 2679 GV * const gv = MUTABLE_GV(POPs); 2680 IO * const io = GvIOn(gv); 2681 2682 if (!IoIFP(io)) 2683 goto nuts; 2684 2685 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); 2686 RETURN; 2687 2688 nuts: 2689 report_evil_fh(gv); 2690 SETERRNO(EBADF,SS_IVCHAN); 2691 RETPUSHUNDEF; 2692 } 2693 2694 #ifndef PERL_GETSOCKOPT_SIZE 2695 #define PERL_GETSOCKOPT_SIZE 1024 2696 #endif 2697 2698 /* also used for: pp_gsockopt() */ 2699 2700 PP(pp_ssockopt) 2701 { 2702 dSP; 2703 const int optype = PL_op->op_type; 2704 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(PERL_GETSOCKOPT_SIZE+1)) : POPs; 2705 const unsigned int optname = (unsigned int) POPi; 2706 const unsigned int lvl = (unsigned int) POPi; 2707 GV * const gv = MUTABLE_GV(POPs); 2708 IO * const io = GvIOn(gv); 2709 int fd; 2710 Sock_size_t len; 2711 2712 if (!IoIFP(io)) 2713 goto nuts; 2714 2715 fd = PerlIO_fileno(IoIFP(io)); 2716 if (fd < 0) 2717 goto nuts; 2718 switch (optype) { 2719 case OP_GSOCKOPT: 2720 /* Note: there used to be an explicit SvGROW(sv,257) here, but 2721 * this is redundant given the sv initialization ternary above */ 2722 (void)SvPOK_only(sv); 2723 SvCUR_set(sv, PERL_GETSOCKOPT_SIZE); 2724 *SvEND(sv) ='\0'; 2725 len = SvCUR(sv); 2726 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0) 2727 goto nuts2; 2728 #if defined(_AIX) 2729 /* XXX Configure test: does getsockopt set the length properly? */ 2730 if (len == PERL_GETSOCKOPT_SIZE) 2731 len = sizeof(int); 2732 #endif 2733 SvCUR_set(sv, len); 2734 *SvEND(sv) ='\0'; 2735 PUSHs(sv); 2736 break; 2737 case OP_SSOCKOPT: { 2738 const char *buf; 2739 int aint; 2740 SvGETMAGIC(sv); 2741 if (SvPOK(sv) && !SvIsBOOL(sv)) { /* sv is originally a string */ 2742 STRLEN l; 2743 buf = SvPVbyte_nomg(sv, l); 2744 len = l; 2745 } 2746 else { 2747 aint = (int)SvIV_nomg(sv); 2748 buf = (const char *) &aint; 2749 len = sizeof(int); 2750 } 2751 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) 2752 goto nuts2; 2753 PUSHs(&PL_sv_yes); 2754 } 2755 break; 2756 } 2757 RETURN; 2758 2759 nuts: 2760 report_evil_fh(gv); 2761 SETERRNO(EBADF,SS_IVCHAN); 2762 nuts2: 2763 RETPUSHUNDEF; 2764 2765 } 2766 2767 2768 /* also used for: pp_getsockname() */ 2769 2770 PP(pp_getpeername) 2771 { 2772 dSP; 2773 const int optype = PL_op->op_type; 2774 GV * const gv = MUTABLE_GV(POPs); 2775 IO * const io = GvIOn(gv); 2776 Sock_size_t len; 2777 SV *sv; 2778 int fd; 2779 2780 if (!IoIFP(io)) 2781 goto nuts; 2782 2783 #ifdef HAS_SOCKADDR_STORAGE 2784 len = sizeof(struct sockaddr_storage); 2785 #else 2786 len = 256; 2787 #endif 2788 sv = sv_2mortal(newSV(len+1)); 2789 (void)SvPOK_only(sv); 2790 SvCUR_set(sv, len); 2791 *SvEND(sv) ='\0'; 2792 fd = PerlIO_fileno(IoIFP(io)); 2793 if (fd < 0) 2794 goto nuts; 2795 switch (optype) { 2796 case OP_GETSOCKNAME: 2797 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) 2798 goto nuts2; 2799 break; 2800 case OP_GETPEERNAME: 2801 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) 2802 goto nuts2; 2803 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS) 2804 { 2805 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; 2806 /* If the call succeeded, make sure we don't have a zeroed port/addr */ 2807 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && 2808 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, 2809 sizeof(u_short) + sizeof(struct in_addr))) { 2810 goto nuts2; 2811 } 2812 } 2813 #endif 2814 break; 2815 } 2816 #ifdef BOGUS_GETNAME_RETURN 2817 /* Interactive Unix, getpeername() and getsockname() 2818 does not return valid namelen */ 2819 if (len == BOGUS_GETNAME_RETURN) 2820 len = sizeof(struct sockaddr); 2821 #endif 2822 SvCUR_set(sv, len); 2823 *SvEND(sv) ='\0'; 2824 PUSHs(sv); 2825 RETURN; 2826 2827 nuts: 2828 report_evil_fh(gv); 2829 SETERRNO(EBADF,SS_IVCHAN); 2830 nuts2: 2831 RETPUSHUNDEF; 2832 } 2833 2834 #endif 2835 2836 /* Stat calls. */ 2837 2838 /* also used for: pp_lstat() */ 2839 2840 PP(pp_stat) 2841 { 2842 dSP; 2843 GV *gv = NULL; 2844 IO *io = NULL; 2845 U8 gimme; 2846 I32 max = 13; 2847 SV* sv; 2848 2849 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1) 2850 : cBOOL((sv=POPs, gv = MAYBE_DEREF_GV(sv)))) 2851 { 2852 if (PL_op->op_type == OP_LSTAT) { 2853 if (gv != PL_defgv) { 2854 do_fstat_warning_check: 2855 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 2856 "lstat() on filehandle%s%" SVf, 2857 gv ? " " : "", 2858 SVfARG(gv 2859 ? newSVhek_mortal(GvENAME_HEK(gv)) 2860 : &PL_sv_no)); 2861 } else if (PL_laststype != OP_LSTAT) 2862 /* diag_listed_as: The stat preceding %s wasn't an lstat */ 2863 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); 2864 } 2865 2866 if (gv == PL_defgv) { 2867 if (PL_laststatval < 0) 2868 SETERRNO(EBADF,RMS_IFI); 2869 } else { 2870 do_fstat_have_io: 2871 PL_laststype = OP_STAT; 2872 PL_statgv = gv ? gv : (GV *)io; 2873 SvPVCLEAR(PL_statname); 2874 if(gv) { 2875 io = GvIO(gv); 2876 } 2877 if (io) { 2878 if (IoIFP(io)) { 2879 int fd = PerlIO_fileno(IoIFP(io)); 2880 if (fd < 0) { 2881 report_evil_fh(gv); 2882 PL_laststatval = -1; 2883 SETERRNO(EBADF,RMS_IFI); 2884 } else { 2885 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); 2886 } 2887 } else if (IoDIRP(io)) { 2888 PL_laststatval = 2889 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); 2890 } else { 2891 report_evil_fh(gv); 2892 PL_laststatval = -1; 2893 SETERRNO(EBADF,RMS_IFI); 2894 } 2895 } else { 2896 report_evil_fh(gv); 2897 PL_laststatval = -1; 2898 SETERRNO(EBADF,RMS_IFI); 2899 } 2900 } 2901 2902 if (PL_laststatval < 0) { 2903 max = 0; 2904 } 2905 } 2906 else { 2907 const char *file; 2908 const char *temp; 2909 STRLEN len; 2910 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 2911 io = MUTABLE_IO(SvRV(sv)); 2912 if (PL_op->op_type == OP_LSTAT) 2913 goto do_fstat_warning_check; 2914 goto do_fstat_have_io; 2915 } 2916 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */ 2917 temp = SvPV_nomg_const(sv, len); 2918 sv_setpv(PL_statname, temp); 2919 PL_statgv = NULL; 2920 PL_laststype = PL_op->op_type; 2921 file = SvPV_nolen_const(PL_statname); 2922 if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) { 2923 PL_laststatval = -1; 2924 } 2925 else if (PL_op->op_type == OP_LSTAT) 2926 PL_laststatval = PerlLIO_lstat(file, &PL_statcache); 2927 else 2928 PL_laststatval = PerlLIO_stat(file, &PL_statcache); 2929 if (PL_laststatval < 0) { 2930 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { 2931 /* PL_warn_nl is constant */ 2932 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); 2933 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); 2934 GCC_DIAG_RESTORE_STMT; 2935 } 2936 max = 0; 2937 } 2938 } 2939 2940 gimme = GIMME_V; 2941 if (gimme != G_LIST) { 2942 if (gimme != G_VOID) 2943 XPUSHs(boolSV(max)); 2944 RETURN; 2945 } 2946 if (max) { 2947 EXTEND(SP, max); 2948 EXTEND_MORTAL(max); 2949 #if ST_DEV_SIZE < IVSIZE || (ST_DEV_SIZE == IVSIZE && ST_DEV_SIGN < 0) 2950 mPUSHi(PL_statcache.st_dev); 2951 #elif ST_DEV_SIZE == IVSIZE 2952 mPUSHu(PL_statcache.st_dev); 2953 #else 2954 # if ST_DEV_SIGN < 0 2955 if (LIKELY((IV)PL_statcache.st_dev == PL_statcache.st_dev)) { 2956 mPUSHi((IV)PL_statcache.st_dev); 2957 } 2958 # else 2959 if (LIKELY((UV)PL_statcache.st_dev == PL_statcache.st_dev)) { 2960 mPUSHu((UV)PL_statcache.st_dev); 2961 } 2962 # endif 2963 else { 2964 char buf[sizeof(PL_statcache.st_dev)*3+1]; 2965 /* sv_catpvf() casts 'j' size values down to IV, so it 2966 isn't suitable for use here. 2967 */ 2968 # if defined(I_INTTYPES) && defined(HAS_SNPRINTF) 2969 # if ST_DEV_SIGN < 0 2970 int size = snprintf(buf, sizeof(buf), "%" PRIdMAX, (intmax_t)PL_statcache.st_dev); 2971 # else 2972 int size = snprintf(buf, sizeof(buf), "%" PRIuMAX, (uintmax_t)PL_statcache.st_dev); 2973 # endif 2974 STATIC_ASSERT_STMT(sizeof(intmax_t) >= sizeof(PL_statcache.st_dev)); 2975 mPUSHp(buf, size); 2976 # else 2977 # error extraordinarily large st_dev but no inttypes.h or no snprintf 2978 # endif 2979 } 2980 #endif 2981 { 2982 /* 2983 * We try to represent st_ino as a native IV or UV where 2984 * possible, but fall back to a decimal string where 2985 * necessary. The code to generate these decimal strings 2986 * is quite obtuse, because (a) we're portable to non-POSIX 2987 * platforms where st_ino might be signed; (b) we didn't 2988 * necessarily detect at Configure time whether st_ino is 2989 * signed; (c) we're portable to non-POSIX platforms where 2990 * ino_t isn't defined, so have no name for the type of 2991 * st_ino; and (d) sprintf() doesn't necessarily support 2992 * integers as large as st_ino. 2993 */ 2994 bool neg; 2995 Stat_t s; 2996 CLANG_DIAG_IGNORE_STMT(-Wtautological-compare); 2997 GCC_DIAG_IGNORE_STMT(-Wtype-limits); 2998 #if defined(__HP_cc) || defined(__HP_aCC) 2999 #pragma diag_suppress 2186 3000 #endif 3001 neg = PL_statcache.st_ino < 0; 3002 #if defined(__HP_cc) || defined(__HP_aCC) 3003 #pragma diag_default 2186 3004 #endif 3005 GCC_DIAG_RESTORE_STMT; 3006 CLANG_DIAG_RESTORE_STMT; 3007 if (neg) { 3008 s.st_ino = (IV)PL_statcache.st_ino; 3009 if (LIKELY(s.st_ino == PL_statcache.st_ino)) { 3010 mPUSHi(s.st_ino); 3011 } else { 3012 char buf[sizeof(s.st_ino)*3+1], *p; 3013 s.st_ino = PL_statcache.st_ino; 3014 for (p = buf + sizeof(buf); p != buf+1; ) { 3015 Stat_t t; 3016 t.st_ino = s.st_ino / 10; 3017 *--p = '0' + (int)(t.st_ino*10 - s.st_ino); 3018 s.st_ino = t.st_ino; 3019 } 3020 while (*p == '0') 3021 p++; 3022 *--p = '-'; 3023 mPUSHp(p, buf+sizeof(buf) - p); 3024 } 3025 } else { 3026 s.st_ino = (UV)PL_statcache.st_ino; 3027 if (LIKELY(s.st_ino == PL_statcache.st_ino)) { 3028 mPUSHu(s.st_ino); 3029 } else { 3030 char buf[sizeof(s.st_ino)*3], *p; 3031 s.st_ino = PL_statcache.st_ino; 3032 for (p = buf + sizeof(buf); p != buf; ) { 3033 Stat_t t; 3034 t.st_ino = s.st_ino / 10; 3035 *--p = '0' + (int)(s.st_ino - t.st_ino*10); 3036 s.st_ino = t.st_ino; 3037 } 3038 while (*p == '0') 3039 p++; 3040 mPUSHp(p, buf+sizeof(buf) - p); 3041 } 3042 } 3043 } 3044 mPUSHu(PL_statcache.st_mode); 3045 mPUSHu(PL_statcache.st_nlink); 3046 3047 sv_setuid(PUSHmortal, PL_statcache.st_uid); 3048 sv_setgid(PUSHmortal, PL_statcache.st_gid); 3049 3050 #ifdef USE_STAT_RDEV 3051 mPUSHi(PL_statcache.st_rdev); 3052 #else 3053 PUSHs(newSVpvs_flags("", SVs_TEMP)); 3054 #endif 3055 #if Off_t_size > IVSIZE 3056 mPUSHn(PL_statcache.st_size); 3057 #else 3058 mPUSHi(PL_statcache.st_size); 3059 #endif 3060 #ifdef BIG_TIME 3061 mPUSHn(PL_statcache.st_atime); 3062 mPUSHn(PL_statcache.st_mtime); 3063 mPUSHn(PL_statcache.st_ctime); 3064 #else 3065 mPUSHi(PL_statcache.st_atime); 3066 mPUSHi(PL_statcache.st_mtime); 3067 mPUSHi(PL_statcache.st_ctime); 3068 #endif 3069 #ifdef USE_STAT_BLOCKS 3070 mPUSHu(PL_statcache.st_blksize); 3071 mPUSHu(PL_statcache.st_blocks); 3072 #else 3073 PUSHs(newSVpvs_flags("", SVs_TEMP)); 3074 PUSHs(newSVpvs_flags("", SVs_TEMP)); 3075 #endif 3076 } 3077 RETURN; 3078 } 3079 3080 /* All filetest ops avoid manipulating the perl stack pointer in their main 3081 bodies (since commit d2c4d2d1e22d3125), and return using either 3082 S_ft_return_false() or S_ft_return_true(). These two helper functions are 3083 the only two which manipulate the perl stack. To ensure that no stack 3084 manipulation macros are used, the filetest ops avoid defining a local copy 3085 of the stack pointer with dSP. */ 3086 3087 /* If the next filetest is stacked up with this one 3088 (PL_op->op_private & OPpFT_STACKING), we leave 3089 the original argument on the stack for success, 3090 and skip the stacked operators on failure. 3091 The next few macros/functions take care of this. 3092 */ 3093 3094 static OP * 3095 S_ft_return_false(pTHX_ SV *ret) { 3096 OP *next = NORMAL; 3097 dSP; 3098 3099 if (PL_op->op_flags & OPf_REF) XPUSHs(ret); 3100 else SETs(ret); 3101 PUTBACK; 3102 3103 if (PL_op->op_private & OPpFT_STACKING) { 3104 while (next && OP_IS_FILETEST(next->op_type) 3105 && next->op_private & OPpFT_STACKED) 3106 next = next->op_next; 3107 } 3108 return next; 3109 } 3110 3111 PERL_STATIC_INLINE OP * 3112 S_ft_return_true(pTHX_ SV *ret) { 3113 dSP; 3114 if (PL_op->op_flags & OPf_REF) 3115 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret)); 3116 else if (!(PL_op->op_private & OPpFT_STACKING)) 3117 SETs(ret); 3118 PUTBACK; 3119 return NORMAL; 3120 } 3121 3122 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no) 3123 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef) 3124 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes) 3125 3126 /* NB: OPf_REF implies '-X _' and thus no arg on the stack */ 3127 #define tryAMAGICftest_MG(chr) STMT_START { \ 3128 if ( !(PL_op->op_flags & OPf_REF) \ 3129 && (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG))) \ 3130 { \ 3131 OP *next = S_try_amagic_ftest(aTHX_ chr); \ 3132 if (next) return next; \ 3133 } \ 3134 } STMT_END 3135 3136 STATIC OP * 3137 S_try_amagic_ftest(pTHX_ char chr) { 3138 SV *const arg = *PL_stack_sp; 3139 3140 assert(chr != '?'); 3141 if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg); 3142 3143 if (SvAMAGIC(arg)) 3144 { 3145 const char tmpchr = chr; 3146 SV * const tmpsv = amagic_call(arg, 3147 newSVpvn_flags(&tmpchr, 1, SVs_TEMP), 3148 ftest_amg, AMGf_unary); 3149 3150 if (!tmpsv) 3151 return NULL; 3152 3153 return SvTRUE(tmpsv) 3154 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv); 3155 } 3156 return NULL; 3157 } 3158 3159 3160 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec() 3161 * pp_ftrwrite() */ 3162 3163 PP(pp_ftrread) 3164 { 3165 I32 result; 3166 /* Not const, because things tweak this below. Not bool, because there's 3167 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */ 3168 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) 3169 I32 use_access = PL_op->op_private & OPpFT_ACCESS; 3170 /* Giving some sort of initial value silences compilers. */ 3171 # ifdef R_OK 3172 int access_mode = R_OK; 3173 # else 3174 int access_mode = 0; 3175 # endif 3176 #else 3177 /* access_mode is never used, but leaving use_access in makes the 3178 conditional compiling below much clearer. */ 3179 I32 use_access = 0; 3180 #endif 3181 Mode_t stat_mode = S_IRUSR; 3182 3183 bool effective = FALSE; 3184 char opchar = '?'; 3185 3186 switch (PL_op->op_type) { 3187 case OP_FTRREAD: opchar = 'R'; break; 3188 case OP_FTRWRITE: opchar = 'W'; break; 3189 case OP_FTREXEC: opchar = 'X'; break; 3190 case OP_FTEREAD: opchar = 'r'; break; 3191 case OP_FTEWRITE: opchar = 'w'; break; 3192 case OP_FTEEXEC: opchar = 'x'; break; 3193 } 3194 tryAMAGICftest_MG(opchar); 3195 3196 switch (PL_op->op_type) { 3197 case OP_FTRREAD: 3198 #if !(defined(HAS_ACCESS) && defined(R_OK)) 3199 use_access = 0; 3200 #endif 3201 break; 3202 3203 case OP_FTRWRITE: 3204 #if defined(HAS_ACCESS) && defined(W_OK) 3205 access_mode = W_OK; 3206 #else 3207 use_access = 0; 3208 #endif 3209 stat_mode = S_IWUSR; 3210 break; 3211 3212 case OP_FTREXEC: 3213 #if defined(HAS_ACCESS) && defined(X_OK) 3214 access_mode = X_OK; 3215 #else 3216 use_access = 0; 3217 #endif 3218 stat_mode = S_IXUSR; 3219 break; 3220 3221 case OP_FTEWRITE: 3222 #ifdef PERL_EFF_ACCESS 3223 access_mode = W_OK; 3224 #endif 3225 stat_mode = S_IWUSR; 3226 /* FALLTHROUGH */ 3227 3228 case OP_FTEREAD: 3229 #ifndef PERL_EFF_ACCESS 3230 use_access = 0; 3231 #endif 3232 effective = TRUE; 3233 break; 3234 3235 case OP_FTEEXEC: 3236 #ifdef PERL_EFF_ACCESS 3237 access_mode = X_OK; 3238 #else 3239 use_access = 0; 3240 #endif 3241 stat_mode = S_IXUSR; 3242 effective = TRUE; 3243 break; 3244 } 3245 3246 if (use_access) { 3247 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) 3248 STRLEN len; 3249 const char *name = SvPV(*PL_stack_sp, len); 3250 if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) { 3251 result = -1; 3252 } 3253 else if (effective) { 3254 # ifdef PERL_EFF_ACCESS 3255 result = PERL_EFF_ACCESS(name, access_mode); 3256 # else 3257 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s", 3258 OP_NAME(PL_op)); 3259 # endif 3260 } 3261 else { 3262 # ifdef HAS_ACCESS 3263 result = access(name, access_mode); 3264 # else 3265 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op)); 3266 # endif 3267 } 3268 if (result == 0) 3269 FT_RETURNYES; 3270 if (result < 0) 3271 FT_RETURNUNDEF; 3272 FT_RETURNNO; 3273 #endif 3274 } 3275 3276 result = my_stat_flags(0); 3277 if (result < 0) 3278 FT_RETURNUNDEF; 3279 if (cando(stat_mode, effective, &PL_statcache)) 3280 FT_RETURNYES; 3281 FT_RETURNNO; 3282 } 3283 3284 3285 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */ 3286 3287 PP(pp_ftis) 3288 { 3289 I32 result; 3290 const int op_type = PL_op->op_type; 3291 char opchar = '?'; 3292 3293 switch (op_type) { 3294 case OP_FTIS: opchar = 'e'; break; 3295 case OP_FTSIZE: opchar = 's'; break; 3296 case OP_FTMTIME: opchar = 'M'; break; 3297 case OP_FTCTIME: opchar = 'C'; break; 3298 case OP_FTATIME: opchar = 'A'; break; 3299 } 3300 tryAMAGICftest_MG(opchar); 3301 3302 result = my_stat_flags(0); 3303 if (result < 0) 3304 FT_RETURNUNDEF; 3305 if (op_type == OP_FTIS) 3306 FT_RETURNYES; 3307 { 3308 /* You can't dTARGET inside OP_FTIS, because you'll get 3309 "panic: pad_sv po" - the op is not flagged to have a target. */ 3310 dTARGET; 3311 switch (op_type) { 3312 case OP_FTSIZE: 3313 #if Off_t_size > IVSIZE 3314 sv_setnv(TARG, (NV)PL_statcache.st_size); 3315 #else 3316 sv_setiv(TARG, (IV)PL_statcache.st_size); 3317 #endif 3318 break; 3319 case OP_FTMTIME: 3320 sv_setnv(TARG, 3321 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 ); 3322 break; 3323 case OP_FTATIME: 3324 sv_setnv(TARG, 3325 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 ); 3326 break; 3327 case OP_FTCTIME: 3328 sv_setnv(TARG, 3329 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 ); 3330 break; 3331 } 3332 SvSETMAGIC(TARG); 3333 return SvTRUE_nomg_NN(TARG) 3334 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG); 3335 } 3336 } 3337 3338 3339 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned() 3340 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock() 3341 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */ 3342 3343 PP(pp_ftrowned) 3344 { 3345 I32 result; 3346 char opchar = '?'; 3347 3348 switch (PL_op->op_type) { 3349 case OP_FTROWNED: opchar = 'O'; break; 3350 case OP_FTEOWNED: opchar = 'o'; break; 3351 case OP_FTZERO: opchar = 'z'; break; 3352 case OP_FTSOCK: opchar = 'S'; break; 3353 case OP_FTCHR: opchar = 'c'; break; 3354 case OP_FTBLK: opchar = 'b'; break; 3355 case OP_FTFILE: opchar = 'f'; break; 3356 case OP_FTDIR: opchar = 'd'; break; 3357 case OP_FTPIPE: opchar = 'p'; break; 3358 case OP_FTSUID: opchar = 'u'; break; 3359 case OP_FTSGID: opchar = 'g'; break; 3360 case OP_FTSVTX: opchar = 'k'; break; 3361 } 3362 tryAMAGICftest_MG(opchar); 3363 3364 result = my_stat_flags(0); 3365 if (result < 0) 3366 FT_RETURNUNDEF; 3367 switch (PL_op->op_type) { 3368 case OP_FTROWNED: 3369 if (PL_statcache.st_uid == PerlProc_getuid()) 3370 FT_RETURNYES; 3371 break; 3372 case OP_FTEOWNED: 3373 if (PL_statcache.st_uid == PerlProc_geteuid()) 3374 FT_RETURNYES; 3375 break; 3376 case OP_FTZERO: 3377 if (PL_statcache.st_size == 0) 3378 FT_RETURNYES; 3379 break; 3380 case OP_FTSOCK: 3381 if (S_ISSOCK(PL_statcache.st_mode)) 3382 FT_RETURNYES; 3383 break; 3384 case OP_FTCHR: 3385 if (S_ISCHR(PL_statcache.st_mode)) 3386 FT_RETURNYES; 3387 break; 3388 case OP_FTBLK: 3389 if (S_ISBLK(PL_statcache.st_mode)) 3390 FT_RETURNYES; 3391 break; 3392 case OP_FTFILE: 3393 if (S_ISREG(PL_statcache.st_mode)) 3394 FT_RETURNYES; 3395 break; 3396 case OP_FTDIR: 3397 if (S_ISDIR(PL_statcache.st_mode)) 3398 FT_RETURNYES; 3399 break; 3400 case OP_FTPIPE: 3401 if (S_ISFIFO(PL_statcache.st_mode)) 3402 FT_RETURNYES; 3403 break; 3404 #ifdef S_ISUID 3405 case OP_FTSUID: 3406 if (PL_statcache.st_mode & S_ISUID) 3407 FT_RETURNYES; 3408 break; 3409 #endif 3410 #ifdef S_ISGID 3411 case OP_FTSGID: 3412 if (PL_statcache.st_mode & S_ISGID) 3413 FT_RETURNYES; 3414 break; 3415 #endif 3416 #ifdef S_ISVTX 3417 case OP_FTSVTX: 3418 if (PL_statcache.st_mode & S_ISVTX) 3419 FT_RETURNYES; 3420 break; 3421 #endif 3422 } 3423 FT_RETURNNO; 3424 } 3425 3426 PP(pp_ftlink) 3427 { 3428 I32 result; 3429 3430 tryAMAGICftest_MG('l'); 3431 result = my_lstat_flags(0); 3432 3433 if (result < 0) 3434 FT_RETURNUNDEF; 3435 if (S_ISLNK(PL_statcache.st_mode)) 3436 FT_RETURNYES; 3437 FT_RETURNNO; 3438 } 3439 3440 PP(pp_fttty) 3441 { 3442 int fd; 3443 GV *gv; 3444 char *name = NULL; 3445 STRLEN namelen; 3446 UV uv; 3447 3448 tryAMAGICftest_MG('t'); 3449 3450 if (PL_op->op_flags & OPf_REF) 3451 gv = cGVOP_gv; 3452 else { 3453 SV *tmpsv = *PL_stack_sp; 3454 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) { 3455 name = SvPV_nomg(tmpsv, namelen); 3456 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); 3457 } 3458 } 3459 3460 if (GvIO(gv) && IoIFP(GvIOp(gv))) 3461 fd = PerlIO_fileno(IoIFP(GvIOp(gv))); 3462 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX) 3463 fd = (int)uv; 3464 else 3465 fd = -1; 3466 if (fd < 0) { 3467 SETERRNO(EBADF,RMS_IFI); 3468 FT_RETURNUNDEF; 3469 } 3470 if (PerlLIO_isatty(fd)) 3471 FT_RETURNYES; 3472 FT_RETURNNO; 3473 } 3474 3475 3476 /* also used for: pp_ftbinary() */ 3477 3478 PP(pp_fttext) 3479 { 3480 I32 i; 3481 SSize_t len; 3482 I32 odd = 0; 3483 STDCHAR tbuf[512]; 3484 STDCHAR *s; 3485 IO *io; 3486 SV *sv = NULL; 3487 GV *gv; 3488 PerlIO *fp; 3489 const U8 * first_variant; 3490 3491 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); 3492 3493 if (PL_op->op_flags & OPf_REF) 3494 gv = cGVOP_gv; 3495 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 3496 == OPpFT_STACKED) 3497 gv = PL_defgv; 3498 else { 3499 sv = *PL_stack_sp; 3500 gv = MAYBE_DEREF_GV_nomg(sv); 3501 } 3502 3503 if (gv) { 3504 if (gv == PL_defgv) { 3505 if (PL_statgv) 3506 io = SvTYPE(PL_statgv) == SVt_PVIO 3507 ? (IO *)PL_statgv 3508 : GvIO(PL_statgv); 3509 else { 3510 goto really_filename; 3511 } 3512 } 3513 else { 3514 PL_statgv = gv; 3515 SvPVCLEAR(PL_statname); 3516 io = GvIO(PL_statgv); 3517 } 3518 PL_laststatval = -1; 3519 PL_laststype = OP_STAT; 3520 if (io && IoIFP(io)) { 3521 int fd; 3522 if (! PerlIO_has_base(IoIFP(io))) 3523 DIE(aTHX_ "-T and -B not implemented on filehandles"); 3524 fd = PerlIO_fileno(IoIFP(io)); 3525 if (fd < 0) { 3526 SETERRNO(EBADF,RMS_IFI); 3527 FT_RETURNUNDEF; 3528 } 3529 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); 3530 if (PL_laststatval < 0) 3531 FT_RETURNUNDEF; 3532 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ 3533 if (PL_op->op_type == OP_FTTEXT) 3534 FT_RETURNNO; 3535 else 3536 FT_RETURNYES; 3537 } 3538 if (PerlIO_get_cnt(IoIFP(io)) <= 0) { 3539 i = PerlIO_getc(IoIFP(io)); 3540 if (i != EOF) 3541 (void)PerlIO_ungetc(IoIFP(io),i); 3542 else 3543 /* null file is anything */ 3544 FT_RETURNYES; 3545 } 3546 len = PerlIO_get_bufsiz(IoIFP(io)); 3547 s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); 3548 /* sfio can have large buffers - limit to 512 */ 3549 if (len > 512) 3550 len = 512; 3551 } 3552 else { 3553 SETERRNO(EBADF,RMS_IFI); 3554 report_evil_fh(gv); 3555 SETERRNO(EBADF,RMS_IFI); 3556 FT_RETURNUNDEF; 3557 } 3558 } 3559 else { 3560 const char *file; 3561 const char *temp; 3562 STRLEN temp_len; 3563 int fd; 3564 3565 assert(sv); 3566 temp = SvPV_nomg_const(sv, temp_len); 3567 sv_setpv(PL_statname, temp); 3568 if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) { 3569 PL_laststatval = -1; 3570 PL_laststype = OP_STAT; 3571 FT_RETURNUNDEF; 3572 } 3573 really_filename: 3574 file = SvPVX_const(PL_statname); 3575 PL_statgv = NULL; 3576 if (!(fp = PerlIO_open(file, "r"))) { 3577 if (!gv) { 3578 PL_laststatval = -1; 3579 PL_laststype = OP_STAT; 3580 } 3581 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { 3582 /* PL_warn_nl is constant */ 3583 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); 3584 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); 3585 GCC_DIAG_RESTORE_STMT; 3586 } 3587 FT_RETURNUNDEF; 3588 } 3589 PL_laststype = OP_STAT; 3590 fd = PerlIO_fileno(fp); 3591 if (fd < 0) { 3592 (void)PerlIO_close(fp); 3593 SETERRNO(EBADF,RMS_IFI); 3594 FT_RETURNUNDEF; 3595 } 3596 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); 3597 if (PL_laststatval < 0) { 3598 dSAVE_ERRNO; 3599 (void)PerlIO_close(fp); 3600 RESTORE_ERRNO; 3601 FT_RETURNUNDEF; 3602 } 3603 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); 3604 len = PerlIO_read(fp, tbuf, sizeof(tbuf)); 3605 (void)PerlIO_close(fp); 3606 if (len <= 0) { 3607 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) 3608 FT_RETURNNO; /* special case NFS directories */ 3609 FT_RETURNYES; /* null file is anything */ 3610 } 3611 s = tbuf; 3612 } 3613 3614 /* now scan s to look for textiness */ 3615 3616 #if defined(DOSISH) || defined(USEMYBINMODE) 3617 /* ignore trailing ^Z on short files */ 3618 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26) 3619 --len; 3620 #endif 3621 3622 assert(len); 3623 if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) { 3624 3625 /* Here contains a variant under UTF-8 . See if the entire string is 3626 * UTF-8. */ 3627 if (is_utf8_fixed_width_buf_flags(first_variant, 3628 len - ((char *) first_variant - (char *) s), 3629 0)) 3630 { 3631 if (PL_op->op_type == OP_FTTEXT) { 3632 FT_RETURNYES; 3633 } 3634 else { 3635 FT_RETURNNO; 3636 } 3637 } 3638 } 3639 3640 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for 3641 * things that wouldn't be in ASCII text or rich ASCII text. Count these 3642 * in 'odd' */ 3643 for (i = 0; i < len; i++, s++) { 3644 if (!*s) { /* null never allowed in text */ 3645 odd += len; 3646 break; 3647 } 3648 #ifdef USE_LOCALE_CTYPE 3649 if (IN_LC_RUNTIME(LC_CTYPE)) { 3650 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) { 3651 continue; 3652 } 3653 } 3654 else 3655 #endif 3656 if ( isPRINT_A(*s) 3657 /* VT occurs so rarely in text, that we consider it odd */ 3658 || (isSPACE_A(*s) && *s != VT_NATIVE) 3659 3660 /* But there is a fair amount of backspaces and escapes in 3661 * some text */ 3662 || *s == '\b' 3663 || *s == ESC_NATIVE) 3664 { 3665 continue; 3666 } 3667 odd++; 3668 } 3669 3670 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ 3671 FT_RETURNNO; 3672 else 3673 FT_RETURNYES; 3674 } 3675 3676 /* File calls. */ 3677 3678 PP(pp_chdir) 3679 { 3680 dSP; dTARGET; 3681 const char *tmps = NULL; 3682 GV *gv = NULL; 3683 3684 if( MAXARG == 1 ) { 3685 SV * const sv = POPs; 3686 if (PL_op->op_flags & OPf_SPECIAL) { 3687 gv = gv_fetchsv(sv, 0, SVt_PVIO); 3688 if (!gv) { 3689 if (ckWARN(WARN_UNOPENED)) { 3690 Perl_warner(aTHX_ packWARN(WARN_UNOPENED), 3691 "chdir() on unopened filehandle %" SVf, sv); 3692 } 3693 SETERRNO(EBADF,RMS_IFI); 3694 PUSHs(&PL_sv_zero); 3695 TAINT_PROPER("chdir"); 3696 RETURN; 3697 } 3698 } 3699 else if (!(gv = MAYBE_DEREF_GV(sv))) 3700 tmps = SvPV_nomg_const_nolen(sv); 3701 } 3702 else { 3703 HV * const table = GvHVn(PL_envgv); 3704 SV **svp; 3705 3706 EXTEND(SP, 1); 3707 if ( (svp = hv_fetchs(table, "HOME", FALSE)) 3708 || (svp = hv_fetchs(table, "LOGDIR", FALSE)) 3709 #ifdef VMS 3710 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE)) 3711 #endif 3712 ) 3713 { 3714 tmps = SvPV_nolen_const(*svp); 3715 } 3716 else { 3717 PUSHs(&PL_sv_zero); 3718 SETERRNO(EINVAL, LIB_INVARG); 3719 TAINT_PROPER("chdir"); 3720 RETURN; 3721 } 3722 } 3723 3724 TAINT_PROPER("chdir"); 3725 if (gv) { 3726 #ifdef HAS_FCHDIR 3727 IO* const io = GvIO(gv); 3728 if (io) { 3729 if (IoDIRP(io)) { 3730 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); 3731 } else if (IoIFP(io)) { 3732 int fd = PerlIO_fileno(IoIFP(io)); 3733 if (fd < 0) { 3734 goto nuts; 3735 } 3736 PUSHi(fchdir(fd) >= 0); 3737 } 3738 else { 3739 goto nuts; 3740 } 3741 } else { 3742 goto nuts; 3743 } 3744 3745 #else 3746 DIE(aTHX_ PL_no_func, "fchdir"); 3747 #endif 3748 } 3749 else 3750 PUSHi( PerlDir_chdir(tmps) >= 0 ); 3751 #ifdef VMS 3752 /* Clear the DEFAULT element of ENV so we'll get the new value 3753 * in the future. */ 3754 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD); 3755 #endif 3756 RETURN; 3757 3758 #ifdef HAS_FCHDIR 3759 nuts: 3760 report_evil_fh(gv); 3761 SETERRNO(EBADF,RMS_IFI); 3762 PUSHs(&PL_sv_zero); 3763 RETURN; 3764 #endif 3765 } 3766 3767 3768 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */ 3769 3770 PP(pp_chown) 3771 { 3772 dSP; dMARK; dTARGET; 3773 const I32 value = (I32)apply(PL_op->op_type, MARK, SP); 3774 3775 SP = MARK; 3776 XPUSHi(value); 3777 RETURN; 3778 } 3779 3780 PP(pp_chroot) 3781 { 3782 #ifdef HAS_CHROOT 3783 dSP; dTARGET; 3784 char * const tmps = POPpx; 3785 TAINT_PROPER("chroot"); 3786 PUSHi( chroot(tmps) >= 0 ); 3787 RETURN; 3788 #else 3789 DIE(aTHX_ PL_no_func, "chroot"); 3790 #endif 3791 } 3792 3793 PP(pp_rename) 3794 { 3795 dSP; dTARGET; 3796 int anum; 3797 #ifndef HAS_RENAME 3798 Stat_t statbuf; 3799 #endif 3800 const char * const tmps2 = POPpconstx; 3801 const char * const tmps = SvPV_nolen_const(TOPs); 3802 TAINT_PROPER("rename"); 3803 #ifdef HAS_RENAME 3804 anum = PerlLIO_rename(tmps, tmps2); 3805 #else 3806 if (!(anum = PerlLIO_stat(tmps, &statbuf))) { 3807 if (same_dirent(tmps2, tmps)) /* can always rename to same name */ 3808 anum = 1; 3809 else { 3810 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) 3811 (void)UNLINK(tmps2); 3812 if (!(anum = link(tmps, tmps2))) 3813 anum = UNLINK(tmps); 3814 } 3815 } 3816 #endif 3817 SETi( anum >= 0 ); 3818 RETURN; 3819 } 3820 3821 3822 /* also used for: pp_symlink() */ 3823 3824 #if defined(HAS_LINK) || defined(HAS_SYMLINK) 3825 PP(pp_link) 3826 { 3827 dSP; dTARGET; 3828 const int op_type = PL_op->op_type; 3829 int result; 3830 3831 # ifndef HAS_LINK 3832 if (op_type == OP_LINK) 3833 DIE(aTHX_ PL_no_func, "link"); 3834 # endif 3835 # ifndef HAS_SYMLINK 3836 if (op_type == OP_SYMLINK) 3837 DIE(aTHX_ PL_no_func, "symlink"); 3838 # endif 3839 3840 { 3841 const char * const tmps2 = POPpconstx; 3842 const char * const tmps = SvPV_nolen_const(TOPs); 3843 TAINT_PROPER(PL_op_desc[op_type]); 3844 result = 3845 # if defined(HAS_LINK) && defined(HAS_SYMLINK) 3846 /* Both present - need to choose which. */ 3847 (op_type == OP_LINK) ? 3848 PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2); 3849 # elif defined(HAS_LINK) 3850 /* Only have link, so calls to pp_symlink will have DIE()d above. */ 3851 PerlLIO_link(tmps, tmps2); 3852 # elif defined(HAS_SYMLINK) 3853 /* Only have symlink, so calls to pp_link will have DIE()d above. */ 3854 PerlLIO_symlink(tmps, tmps2); 3855 # endif 3856 } 3857 3858 SETi( result >= 0 ); 3859 RETURN; 3860 } 3861 #else 3862 3863 /* also used for: pp_symlink() */ 3864 3865 PP(pp_link) 3866 { 3867 /* Have neither. */ 3868 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 3869 } 3870 #endif 3871 3872 PP(pp_readlink) 3873 { 3874 dSP; 3875 #ifdef HAS_SYMLINK 3876 dTARGET; 3877 const char *tmps; 3878 char buf[MAXPATHLEN]; 3879 SSize_t len; 3880 3881 TAINT; 3882 tmps = POPpconstx; 3883 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1, 3884 * it is impossible to know whether the result was truncated. */ 3885 len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1); 3886 if (len < 0) 3887 RETPUSHUNDEF; 3888 buf[len] = '\0'; 3889 PUSHp(buf, len); 3890 RETURN; 3891 #else 3892 EXTEND(SP, 1); 3893 RETSETUNDEF; /* just pretend it's a normal file */ 3894 #endif 3895 } 3896 3897 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) 3898 STATIC int 3899 S_dooneliner(pTHX_ const char *cmd, const char *filename) 3900 { 3901 char * const save_filename = filename; 3902 char *cmdline; 3903 char *s; 3904 PerlIO *myfp; 3905 int anum = 1; 3906 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10; 3907 3908 PERL_ARGS_ASSERT_DOONELINER; 3909 3910 Newx(cmdline, size, char); 3911 my_strlcpy(cmdline, cmd, size); 3912 my_strlcat(cmdline, " ", size); 3913 for (s = cmdline + strlen(cmdline); *filename; ) { 3914 *s++ = '\\'; 3915 *s++ = *filename++; 3916 } 3917 if (s - cmdline < size) 3918 my_strlcpy(s, " 2>&1", size - (s - cmdline)); 3919 myfp = PerlProc_popen(cmdline, "r"); 3920 Safefree(cmdline); 3921 3922 if (myfp) { 3923 SV * const tmpsv = sv_newmortal(); 3924 /* Need to save/restore 'PL_rs' ?? */ 3925 s = sv_gets(tmpsv, myfp, 0); 3926 (void)PerlProc_pclose(myfp); 3927 if (s != NULL) { 3928 int e; 3929 for (e = 1; 3930 #ifdef HAS_SYS_ERRLIST 3931 e <= sys_nerr 3932 #endif 3933 ; e++) 3934 { 3935 /* you don't see this */ 3936 const char * const errmsg = Strerror(e) ; 3937 if (!errmsg) 3938 break; 3939 if (instr(s, errmsg)) { 3940 SETERRNO(e,0); 3941 return 0; 3942 } 3943 } 3944 SETERRNO(0,0); 3945 #ifndef EACCES 3946 #define EACCES EPERM 3947 #endif 3948 if (instr(s, "cannot make")) 3949 SETERRNO(EEXIST,RMS_FEX); 3950 else if (instr(s, "existing file")) 3951 SETERRNO(EEXIST,RMS_FEX); 3952 else if (instr(s, "ile exists")) 3953 SETERRNO(EEXIST,RMS_FEX); 3954 else if (instr(s, "non-exist")) 3955 SETERRNO(ENOENT,RMS_FNF); 3956 else if (instr(s, "does not exist")) 3957 SETERRNO(ENOENT,RMS_FNF); 3958 else if (instr(s, "not empty")) 3959 SETERRNO(EBUSY,SS_DEVOFFLINE); 3960 else if (instr(s, "cannot access")) 3961 SETERRNO(EACCES,RMS_PRV); 3962 else 3963 SETERRNO(EPERM,RMS_PRV); 3964 return 0; 3965 } 3966 else { /* some mkdirs return no failure indication */ 3967 Stat_t statbuf; 3968 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0); 3969 if (PL_op->op_type == OP_RMDIR) 3970 anum = !anum; 3971 if (anum) 3972 SETERRNO(0,0); 3973 else 3974 SETERRNO(EACCES,RMS_PRV); /* a guess */ 3975 } 3976 return anum; 3977 } 3978 else 3979 return 0; 3980 } 3981 #endif 3982 3983 /* This macro removes trailing slashes from a directory name. 3984 * Different operating and file systems take differently to 3985 * trailing slashes. According to POSIX 1003.1 1996 Edition 3986 * any number of trailing slashes should be allowed. 3987 * Thusly we snip them away so that even non-conforming 3988 * systems are happy. 3989 * We should probably do this "filtering" for all 3990 * the functions that expect (potentially) directory names: 3991 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, 3992 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ 3993 3994 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \ 3995 if ((len) > 1 && (tmps)[(len)-1] == '/') { \ 3996 do { \ 3997 (len)--; \ 3998 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \ 3999 (tmps) = savepvn((tmps), (len)); \ 4000 (copy) = TRUE; \ 4001 } 4002 4003 PP(pp_mkdir) 4004 { 4005 dSP; dTARGET; 4006 STRLEN len; 4007 const char *tmps; 4008 bool copy = FALSE; 4009 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777; 4010 4011 TRIMSLASHES(tmps,len,copy); 4012 4013 TAINT_PROPER("mkdir"); 4014 #ifdef HAS_MKDIR 4015 SETi( PerlDir_mkdir(tmps, mode) >= 0 ); 4016 #else 4017 { 4018 int oldumask; 4019 SETi( dooneliner("mkdir", tmps) ); 4020 oldumask = PerlLIO_umask(0); 4021 PerlLIO_umask(oldumask); 4022 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777); 4023 } 4024 #endif 4025 if (copy) 4026 Safefree(tmps); 4027 RETURN; 4028 } 4029 4030 PP(pp_rmdir) 4031 { 4032 dSP; dTARGET; 4033 STRLEN len; 4034 const char *tmps; 4035 bool copy = FALSE; 4036 4037 TRIMSLASHES(tmps,len,copy); 4038 TAINT_PROPER("rmdir"); 4039 #ifdef HAS_RMDIR 4040 SETi( PerlDir_rmdir(tmps) >= 0 ); 4041 #else 4042 SETi( dooneliner("rmdir", tmps) ); 4043 #endif 4044 if (copy) 4045 Safefree(tmps); 4046 RETURN; 4047 } 4048 4049 /* Directory calls. */ 4050 4051 PP(pp_open_dir) 4052 { 4053 #if defined(Direntry_t) && defined(HAS_READDIR) 4054 dSP; 4055 const char * const dirname = POPpconstx; 4056 GV * const gv = MUTABLE_GV(POPs); 4057 IO * const io = GvIOn(gv); 4058 4059 if ((IoIFP(io) || IoOFP(io))) 4060 Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle", 4061 HEKfARG(GvENAME_HEK(gv))); 4062 if (IoDIRP(io)) 4063 PerlDir_close(IoDIRP(io)); 4064 if (!(IoDIRP(io) = PerlDir_open(dirname))) 4065 goto nope; 4066 4067 RETPUSHYES; 4068 nope: 4069 if (!errno) 4070 SETERRNO(EBADF,RMS_DIR); 4071 RETPUSHUNDEF; 4072 #else 4073 DIE(aTHX_ PL_no_dir_func, "opendir"); 4074 #endif 4075 } 4076 4077 PP(pp_readdir) 4078 { 4079 #if !defined(Direntry_t) || !defined(HAS_READDIR) 4080 DIE(aTHX_ PL_no_dir_func, "readdir"); 4081 #else 4082 #if !defined(I_DIRENT) && !defined(VMS) 4083 Direntry_t *readdir (DIR *); 4084 #endif 4085 dSP; 4086 4087 SV *sv; 4088 const U8 gimme = GIMME_V; 4089 GV * const gv = MUTABLE_GV(POPs); 4090 const Direntry_t *dp; 4091 IO * const io = GvIOn(gv); 4092 4093 if (!IoDIRP(io)) { 4094 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4095 "readdir() attempted on invalid dirhandle %" HEKf, 4096 HEKfARG(GvENAME_HEK(gv))); 4097 goto nope; 4098 } 4099 4100 do { 4101 dp = (Direntry_t *)PerlDir_read(IoDIRP(io)); 4102 if (!dp) 4103 break; 4104 #ifdef DIRNAMLEN 4105 sv = newSVpvn(dp->d_name, dp->d_namlen); 4106 #else 4107 sv = newSVpv(dp->d_name, 0); 4108 #endif 4109 if (!(IoFLAGS(io) & IOf_UNTAINT)) 4110 SvTAINTED_on(sv); 4111 mXPUSHs(sv); 4112 } while (gimme == G_LIST); 4113 4114 if (!dp && gimme != G_LIST) 4115 RETPUSHUNDEF; 4116 4117 RETURN; 4118 4119 nope: 4120 if (!errno) 4121 SETERRNO(EBADF,RMS_ISI); 4122 if (gimme == G_LIST) 4123 RETURN; 4124 else 4125 RETPUSHUNDEF; 4126 #endif 4127 } 4128 4129 PP(pp_telldir) 4130 { 4131 #if defined(HAS_TELLDIR) || defined(telldir) 4132 dSP; dTARGET; 4133 /* XXX does _anyone_ need this? --AD 2/20/1998 */ 4134 /* XXX netbsd still seemed to. 4135 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. 4136 --JHI 1999-Feb-02 */ 4137 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO) 4138 long telldir (DIR *); 4139 # endif 4140 GV * const gv = MUTABLE_GV(POPs); 4141 IO * const io = GvIOn(gv); 4142 4143 if (!IoDIRP(io)) { 4144 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4145 "telldir() attempted on invalid dirhandle %" HEKf, 4146 HEKfARG(GvENAME_HEK(gv))); 4147 goto nope; 4148 } 4149 4150 PUSHi( PerlDir_tell(IoDIRP(io)) ); 4151 RETURN; 4152 nope: 4153 if (!errno) 4154 SETERRNO(EBADF,RMS_ISI); 4155 RETPUSHUNDEF; 4156 #else 4157 DIE(aTHX_ PL_no_dir_func, "telldir"); 4158 #endif 4159 } 4160 4161 PP(pp_seekdir) 4162 { 4163 #if defined(HAS_SEEKDIR) || defined(seekdir) 4164 dSP; 4165 const long along = POPl; 4166 GV * const gv = MUTABLE_GV(POPs); 4167 IO * const io = GvIOn(gv); 4168 4169 if (!IoDIRP(io)) { 4170 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4171 "seekdir() attempted on invalid dirhandle %" HEKf, 4172 HEKfARG(GvENAME_HEK(gv))); 4173 goto nope; 4174 } 4175 (void)PerlDir_seek(IoDIRP(io), along); 4176 4177 RETPUSHYES; 4178 nope: 4179 if (!errno) 4180 SETERRNO(EBADF,RMS_ISI); 4181 RETPUSHUNDEF; 4182 #else 4183 DIE(aTHX_ PL_no_dir_func, "seekdir"); 4184 #endif 4185 } 4186 4187 PP(pp_rewinddir) 4188 { 4189 #if defined(HAS_REWINDDIR) || defined(rewinddir) 4190 dSP; 4191 GV * const gv = MUTABLE_GV(POPs); 4192 IO * const io = GvIOn(gv); 4193 4194 if (!IoDIRP(io)) { 4195 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4196 "rewinddir() attempted on invalid dirhandle %" HEKf, 4197 HEKfARG(GvENAME_HEK(gv))); 4198 goto nope; 4199 } 4200 (void)PerlDir_rewind(IoDIRP(io)); 4201 RETPUSHYES; 4202 nope: 4203 if (!errno) 4204 SETERRNO(EBADF,RMS_ISI); 4205 RETPUSHUNDEF; 4206 #else 4207 DIE(aTHX_ PL_no_dir_func, "rewinddir"); 4208 #endif 4209 } 4210 4211 PP(pp_closedir) 4212 { 4213 #if defined(Direntry_t) && defined(HAS_READDIR) 4214 dSP; 4215 GV * const gv = MUTABLE_GV(POPs); 4216 IO * const io = GvIOn(gv); 4217 4218 if (!IoDIRP(io)) { 4219 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4220 "closedir() attempted on invalid dirhandle %" HEKf, 4221 HEKfARG(GvENAME_HEK(gv))); 4222 goto nope; 4223 } 4224 #ifdef VOID_CLOSEDIR 4225 PerlDir_close(IoDIRP(io)); 4226 #else 4227 if (PerlDir_close(IoDIRP(io)) < 0) { 4228 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */ 4229 goto nope; 4230 } 4231 #endif 4232 IoDIRP(io) = 0; 4233 4234 RETPUSHYES; 4235 nope: 4236 if (!errno) 4237 SETERRNO(EBADF,RMS_IFI); 4238 RETPUSHUNDEF; 4239 #else 4240 DIE(aTHX_ PL_no_dir_func, "closedir"); 4241 #endif 4242 } 4243 4244 /* Process control. */ 4245 4246 PP(pp_fork) 4247 { 4248 #ifdef HAS_FORK 4249 dSP; dTARGET; 4250 Pid_t childpid; 4251 #ifdef HAS_SIGPROCMASK 4252 sigset_t oldmask, newmask; 4253 #endif 4254 4255 4256 EXTEND(SP, 1); 4257 PERL_FLUSHALL_FOR_CHILD; 4258 #ifdef HAS_SIGPROCMASK 4259 sigfillset(&newmask); 4260 sigprocmask(SIG_SETMASK, &newmask, &oldmask); 4261 #endif 4262 childpid = PerlProc_fork(); 4263 if (childpid == 0) { 4264 int sig; 4265 PL_sig_pending = 0; 4266 if (PL_psig_pend) 4267 for (sig = 1; sig < SIG_SIZE; sig++) 4268 PL_psig_pend[sig] = 0; 4269 } 4270 #ifdef HAS_SIGPROCMASK 4271 { 4272 dSAVE_ERRNO; 4273 sigprocmask(SIG_SETMASK, &oldmask, NULL); 4274 RESTORE_ERRNO; 4275 } 4276 #endif 4277 if (childpid < 0) 4278 RETPUSHUNDEF; 4279 if (!childpid) { 4280 #ifdef PERL_USES_PL_PIDSTATUS 4281 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ 4282 #endif 4283 PERL_SRAND_OVERRIDE_NEXT_CHILD(); 4284 } else { 4285 PERL_SRAND_OVERRIDE_NEXT_PARENT(); 4286 } 4287 PUSHi(childpid); 4288 RETURN; 4289 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__) 4290 dSP; dTARGET; 4291 Pid_t childpid; 4292 4293 EXTEND(SP, 1); 4294 PERL_FLUSHALL_FOR_CHILD; 4295 childpid = PerlProc_fork(); 4296 if (childpid == -1) 4297 RETPUSHUNDEF; 4298 else if (childpid) { 4299 /* we are in the parent */ 4300 PERL_SRAND_OVERRIDE_NEXT_PARENT(); 4301 } 4302 else { 4303 /* This is part of the logic supporting the env var 4304 * PERL_RAND_SEED which causes use of rand() without an 4305 * explicit srand() to use a deterministic seed. This logic is 4306 * intended to give most forked children of a process a 4307 * deterministic but different srand seed. 4308 */ 4309 PERL_SRAND_OVERRIDE_NEXT_CHILD(); 4310 } 4311 PUSHi(childpid); 4312 RETURN; 4313 #else 4314 DIE(aTHX_ PL_no_func, "fork"); 4315 #endif 4316 } 4317 4318 PP(pp_wait) 4319 { 4320 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) 4321 dSP; dTARGET; 4322 Pid_t childpid; 4323 int argflags; 4324 4325 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 4326 childpid = wait4pid(-1, &argflags, 0); 4327 else { 4328 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && 4329 errno == EINTR) { 4330 PERL_ASYNC_CHECK(); 4331 } 4332 } 4333 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 4334 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ 4335 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1); 4336 # else 4337 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1); 4338 # endif 4339 XPUSHi(childpid); 4340 RETURN; 4341 #else 4342 DIE(aTHX_ PL_no_func, "wait"); 4343 #endif 4344 } 4345 4346 PP(pp_waitpid) 4347 { 4348 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) 4349 dSP; dTARGET; 4350 const int optype = POPi; 4351 const Pid_t pid = TOPi; 4352 Pid_t result; 4353 #ifdef __amigaos4__ 4354 int argflags = 0; 4355 result = amigaos_waitpid(aTHX_ optype, pid, &argflags); 4356 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1); 4357 result = result == 0 ? pid : -1; 4358 #else 4359 int argflags; 4360 4361 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 4362 result = wait4pid(pid, &argflags, optype); 4363 else { 4364 while ((result = wait4pid(pid, &argflags, optype)) == -1 && 4365 errno == EINTR) { 4366 PERL_ASYNC_CHECK(); 4367 } 4368 } 4369 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 4370 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ 4371 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1); 4372 # else 4373 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); 4374 # endif 4375 # endif /* __amigaos4__ */ 4376 SETi(result); 4377 RETURN; 4378 #else 4379 DIE(aTHX_ PL_no_func, "waitpid"); 4380 #endif 4381 } 4382 4383 PP(pp_system) 4384 { 4385 dSP; dMARK; dORIGMARK; dTARGET; 4386 #if defined(__LIBCATAMOUNT__) 4387 PL_statusvalue = -1; 4388 SP = ORIGMARK; 4389 XPUSHi(-1); 4390 #else 4391 I32 value; 4392 # ifdef __amigaos4__ 4393 void * result; 4394 # else 4395 int result; 4396 # endif 4397 4398 while (++MARK <= SP) { 4399 SV *origsv = *MARK, *copysv; 4400 STRLEN len; 4401 char *pv; 4402 SvGETMAGIC(origsv); 4403 #if defined(WIN32) || defined(__VMS) 4404 /* 4405 * Because of a nasty platform-specific variation on the meaning 4406 * of arguments to this op, we must preserve numeric arguments 4407 * as numeric, not just retain the string value. 4408 */ 4409 if (SvNIOK(origsv) || SvNIOKp(origsv)) { 4410 copysv = newSV_type(SVt_PVNV); 4411 sv_2mortal(copysv); 4412 if (SvPOK(origsv) || SvPOKp(origsv)) { 4413 pv = SvPV_nomg(origsv, len); 4414 sv_setpvn_fresh(copysv, pv, len); 4415 SvPOK_off(copysv); 4416 } 4417 if (SvIOK(origsv) || SvIOKp(origsv)) 4418 SvIV_set(copysv, SvIVX(origsv)); 4419 if (SvNOK(origsv) || SvNOKp(origsv)) 4420 SvNV_set(copysv, SvNVX(origsv)); 4421 SvFLAGS(copysv) |= SvFLAGS(origsv) & 4422 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK| 4423 SVf_UTF8|SVf_IVisUV); 4424 } else 4425 #endif 4426 { 4427 pv = SvPV_nomg(origsv, len); 4428 copysv = newSVpvn_flags(pv, len, 4429 (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP); 4430 } 4431 *MARK = copysv; 4432 } 4433 MARK = ORIGMARK; 4434 4435 if (TAINTING_get) { 4436 TAINT_ENV(); 4437 TAINT_PROPER("system"); 4438 } 4439 PERL_FLUSHALL_FOR_CHILD; 4440 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) 4441 { 4442 #ifdef __amigaos4__ 4443 struct UserData userdata; 4444 pthread_t proc; 4445 #else 4446 Pid_t childpid; 4447 #endif 4448 int pp[2]; 4449 I32 did_pipes = 0; 4450 bool child_success = FALSE; 4451 #ifdef HAS_SIGPROCMASK 4452 sigset_t newset, oldset; 4453 #endif 4454 4455 if (PerlProc_pipe_cloexec(pp) >= 0) 4456 did_pipes = 1; 4457 #ifdef __amigaos4__ 4458 amigaos_fork_set_userdata(aTHX_ 4459 &userdata, 4460 did_pipes, 4461 pp[1], 4462 SP, 4463 mark); 4464 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata); 4465 child_success = proc > 0; 4466 #else 4467 #ifdef HAS_SIGPROCMASK 4468 sigemptyset(&newset); 4469 sigaddset(&newset, SIGCHLD); 4470 sigprocmask(SIG_BLOCK, &newset, &oldset); 4471 #endif 4472 while ((childpid = PerlProc_fork()) == -1) { 4473 if (errno != EAGAIN) { 4474 value = -1; 4475 SP = ORIGMARK; 4476 XPUSHi(value); 4477 if (did_pipes) { 4478 PerlLIO_close(pp[0]); 4479 PerlLIO_close(pp[1]); 4480 } 4481 #ifdef HAS_SIGPROCMASK 4482 sigprocmask(SIG_SETMASK, &oldset, NULL); 4483 #endif 4484 RETURN; 4485 } 4486 sleep(5); 4487 } 4488 child_success = childpid > 0; 4489 #endif 4490 if (child_success) { 4491 Sigsave_t ihand,qhand; /* place to save signals during system() */ 4492 int status; 4493 4494 #ifndef __amigaos4__ 4495 if (did_pipes) 4496 PerlLIO_close(pp[1]); 4497 #endif 4498 #ifndef PERL_MICRO 4499 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); 4500 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); 4501 #endif 4502 #ifdef __amigaos4__ 4503 result = pthread_join(proc, (void **)&status); 4504 #else 4505 do { 4506 result = wait4pid(childpid, &status, 0); 4507 } while (result == -1 && errno == EINTR); 4508 #endif 4509 #ifndef PERL_MICRO 4510 #ifdef HAS_SIGPROCMASK 4511 sigprocmask(SIG_SETMASK, &oldset, NULL); 4512 #endif 4513 (void)rsignal_restore(SIGINT, &ihand); 4514 (void)rsignal_restore(SIGQUIT, &qhand); 4515 #endif 4516 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); 4517 SP = ORIGMARK; 4518 if (did_pipes) { 4519 int errkid; 4520 unsigned n = 0; 4521 4522 while (n < sizeof(int)) { 4523 const SSize_t n1 = PerlLIO_read(pp[0], 4524 (void*)(((char*)&errkid)+n), 4525 (sizeof(int)) - n); 4526 if (n1 <= 0) 4527 break; 4528 n += n1; 4529 } 4530 PerlLIO_close(pp[0]); 4531 if (n) { /* Error */ 4532 if (n != sizeof(int)) 4533 DIE(aTHX_ "panic: kid popen errno read, n=%u", n); 4534 errno = errkid; /* Propagate errno from kid */ 4535 #ifdef __amigaos4__ 4536 /* The pipe always has something in it 4537 * so n alone is not enough. */ 4538 if (errno > 0) 4539 #endif 4540 { 4541 STATUS_NATIVE_CHILD_SET(-1); 4542 } 4543 } 4544 } 4545 XPUSHi(STATUS_CURRENT); 4546 RETURN; 4547 } 4548 #ifndef __amigaos4__ 4549 #ifdef HAS_SIGPROCMASK 4550 sigprocmask(SIG_SETMASK, &oldset, NULL); 4551 #endif 4552 if (did_pipes) 4553 PerlLIO_close(pp[0]); 4554 if (PL_op->op_flags & OPf_STACKED) { 4555 SV * const really = *++MARK; 4556 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); 4557 } 4558 else if (SP - MARK != 1) 4559 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes); 4560 else { 4561 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); 4562 } 4563 #endif /* __amigaos4__ */ 4564 PerlProc__exit(-1); 4565 } 4566 #else /* ! FORK or VMS or OS/2 */ 4567 PL_statusvalue = 0; 4568 result = 0; 4569 if (PL_op->op_flags & OPf_STACKED) { 4570 SV * const really = *++MARK; 4571 # if defined(WIN32) || defined(OS2) || defined(__VMS) 4572 value = (I32)do_aspawn(really, MARK, SP); 4573 # else 4574 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); 4575 # endif 4576 } 4577 else if (SP - MARK != 1) { 4578 # if defined(WIN32) || defined(OS2) || defined(__VMS) 4579 value = (I32)do_aspawn(NULL, MARK, SP); 4580 # else 4581 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); 4582 # endif 4583 } 4584 else { 4585 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); 4586 } 4587 if (PL_statusvalue == -1) /* hint that value must be returned as is */ 4588 result = 1; 4589 STATUS_NATIVE_CHILD_SET(value); 4590 SP = ORIGMARK; 4591 XPUSHi(result ? value : STATUS_CURRENT); 4592 #endif /* !FORK or VMS or OS/2 */ 4593 #endif 4594 RETURN; 4595 } 4596 4597 PP(pp_exec) 4598 { 4599 dSP; dMARK; dORIGMARK; dTARGET; 4600 I32 value; 4601 4602 if (TAINTING_get) { 4603 TAINT_ENV(); 4604 while (++MARK <= SP) { 4605 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ 4606 if (TAINT_get) 4607 break; 4608 } 4609 MARK = ORIGMARK; 4610 TAINT_PROPER("exec"); 4611 } 4612 4613 PERL_FLUSHALL_FOR_CHILD; 4614 if (PL_op->op_flags & OPf_STACKED) { 4615 SV * const really = *++MARK; 4616 value = (I32)do_aexec(really, MARK, SP); 4617 } 4618 else if (SP - MARK != 1) 4619 #ifdef VMS 4620 value = (I32)vms_do_aexec(NULL, MARK, SP); 4621 #else 4622 value = (I32)do_aexec(NULL, MARK, SP); 4623 #endif 4624 else { 4625 #ifdef VMS 4626 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); 4627 #else 4628 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); 4629 #endif 4630 } 4631 SP = ORIGMARK; 4632 XPUSHi(value); 4633 RETURN; 4634 } 4635 4636 PP(pp_getppid) 4637 { 4638 #ifdef HAS_GETPPID 4639 dSP; dTARGET; 4640 XPUSHi( getppid() ); 4641 RETURN; 4642 #else 4643 DIE(aTHX_ PL_no_func, "getppid"); 4644 #endif 4645 } 4646 4647 PP(pp_getpgrp) 4648 { 4649 #ifdef HAS_GETPGRP 4650 dSP; dTARGET; 4651 Pid_t pgrp; 4652 const Pid_t pid = 4653 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); 4654 4655 #ifdef BSD_GETPGRP 4656 pgrp = (I32)BSD_GETPGRP(pid); 4657 #else 4658 if (pid != 0 && pid != PerlProc_getpid()) 4659 DIE(aTHX_ "POSIX getpgrp can't take an argument"); 4660 pgrp = getpgrp(); 4661 #endif 4662 XPUSHi(pgrp); 4663 RETURN; 4664 #else 4665 DIE(aTHX_ PL_no_func, "getpgrp"); 4666 #endif 4667 } 4668 4669 PP(pp_setpgrp) 4670 { 4671 #ifdef HAS_SETPGRP 4672 dSP; dTARGET; 4673 Pid_t pgrp; 4674 Pid_t pid; 4675 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; 4676 if (MAXARG > 0) pid = TOPs ? TOPi : 0; 4677 else { 4678 pid = 0; 4679 EXTEND(SP,1); 4680 SP++; 4681 } 4682 4683 TAINT_PROPER("setpgrp"); 4684 #ifdef BSD_SETPGRP 4685 SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); 4686 #else 4687 if ((pgrp != 0 && pgrp != PerlProc_getpid()) 4688 || (pid != 0 && pid != PerlProc_getpid())) 4689 { 4690 DIE(aTHX_ "setpgrp can't take arguments"); 4691 } 4692 SETi( setpgrp() >= 0 ); 4693 #endif /* USE_BSDPGRP */ 4694 RETURN; 4695 #else 4696 DIE(aTHX_ PL_no_func, "setpgrp"); 4697 #endif 4698 } 4699 4700 /* 4701 * The glibc headers typedef __priority_which_t to an enum under C, but 4702 * under C++, it keeps it as int. -Wc++-compat doesn't know this, so we 4703 * need to explicitly cast it to shut up the warning. 4704 */ 4705 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2)) 4706 # define PRIORITY_WHICH_T(which) (__priority_which_t)which 4707 #else 4708 # define PRIORITY_WHICH_T(which) which 4709 #endif 4710 4711 PP(pp_getpriority) 4712 { 4713 #ifdef HAS_GETPRIORITY 4714 dSP; dTARGET; 4715 const int who = POPi; 4716 const int which = TOPi; 4717 SETi( getpriority(PRIORITY_WHICH_T(which), who) ); 4718 RETURN; 4719 #else 4720 DIE(aTHX_ PL_no_func, "getpriority"); 4721 #endif 4722 } 4723 4724 PP(pp_setpriority) 4725 { 4726 #ifdef HAS_SETPRIORITY 4727 dSP; dTARGET; 4728 const int niceval = POPi; 4729 const int who = POPi; 4730 const int which = TOPi; 4731 TAINT_PROPER("setpriority"); 4732 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); 4733 RETURN; 4734 #else 4735 DIE(aTHX_ PL_no_func, "setpriority"); 4736 #endif 4737 } 4738 4739 #undef PRIORITY_WHICH_T 4740 4741 /* Time calls. */ 4742 4743 PP(pp_time) 4744 { 4745 dSP; dTARGET; 4746 #ifdef BIG_TIME 4747 XPUSHn( (NV)time(NULL) ); 4748 #else 4749 XPUSHu( (UV)time(NULL) ); 4750 #endif 4751 RETURN; 4752 } 4753 4754 PP(pp_tms) 4755 { 4756 #ifdef HAS_TIMES 4757 dSP; 4758 struct tms timesbuf; 4759 4760 EXTEND(SP, 4); 4761 (void)PerlProc_times(×buf); 4762 4763 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick); 4764 if (GIMME_V == G_LIST) { 4765 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick); 4766 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick); 4767 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick); 4768 } 4769 RETURN; 4770 #elif defined(PERL_MICRO) 4771 dSP; 4772 mPUSHn(0.0); 4773 EXTEND(SP, 4); 4774 if (GIMME_V == G_LIST) { 4775 mPUSHn(0.0); 4776 mPUSHn(0.0); 4777 mPUSHn(0.0); 4778 } 4779 RETURN; 4780 #else 4781 DIE(aTHX_ "times not implemented"); 4782 #endif /* HAS_TIMES */ 4783 } 4784 4785 /* The 32 bit int year limits the times we can represent to these 4786 boundaries with a few days wiggle room to account for time zone 4787 offsets 4788 */ 4789 /* Sat Jan 3 00:00:00 -2147481748 */ 4790 #define TIME_LOWER_BOUND -67768100567755200.0 4791 /* Sun Dec 29 12:00:00 2147483647 */ 4792 #define TIME_UPPER_BOUND 67767976233316800.0 4793 4794 4795 /* also used for: pp_localtime() */ 4796 4797 PP(pp_gmtime) 4798 { 4799 dSP; 4800 Time64_T when; 4801 struct TM tmbuf; 4802 struct TM *err; 4803 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime"; 4804 static const char * const dayname[] = 4805 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; 4806 static const char * const monname[] = 4807 {"Jan", "Feb", "Mar", "Apr", "May", "Jun", 4808 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; 4809 4810 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) { 4811 time_t now; 4812 (void)time(&now); 4813 when = (Time64_T)now; 4814 } 4815 else { 4816 NV input = Perl_floor(POPn); 4817 const bool pl_isnan = Perl_isnan(input); 4818 when = (Time64_T)input; 4819 if (UNLIKELY(pl_isnan || when != input)) { 4820 /* diag_listed_as: gmtime(%f) too large */ 4821 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4822 "%s(%.0" NVff ") too large", opname, input); 4823 if (pl_isnan) { 4824 err = NULL; 4825 goto failed; 4826 } 4827 } 4828 } 4829 4830 if ( TIME_LOWER_BOUND > when ) { 4831 /* diag_listed_as: gmtime(%f) too small */ 4832 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4833 "%s(%.0" NVff ") too small", opname, when); 4834 err = NULL; 4835 } 4836 else if( when > TIME_UPPER_BOUND ) { 4837 /* diag_listed_as: gmtime(%f) too small */ 4838 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4839 "%s(%.0" NVff ") too large", opname, when); 4840 err = NULL; 4841 } 4842 else { 4843 if (PL_op->op_type == OP_LOCALTIME) 4844 err = Perl_localtime64_r(&when, &tmbuf); 4845 else 4846 err = Perl_gmtime64_r(&when, &tmbuf); 4847 } 4848 4849 if (err == NULL) { 4850 /* diag_listed_as: gmtime(%f) failed */ 4851 /* XXX %lld broken for quads */ 4852 failed: 4853 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4854 "%s(%.0" NVff ") failed", opname, when); 4855 } 4856 4857 if (GIMME_V != G_LIST) { /* scalar context */ 4858 EXTEND(SP, 1); 4859 if (err == NULL) 4860 RETPUSHUNDEF; 4861 else { 4862 dTARGET; 4863 PUSHs(TARG); 4864 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf, 4865 dayname[tmbuf.tm_wday], 4866 monname[tmbuf.tm_mon], 4867 tmbuf.tm_mday, 4868 tmbuf.tm_hour, 4869 tmbuf.tm_min, 4870 tmbuf.tm_sec, 4871 (IV)tmbuf.tm_year + 1900); 4872 } 4873 } 4874 else { /* list context */ 4875 if ( err == NULL ) 4876 RETURN; 4877 4878 EXTEND(SP, 9); 4879 EXTEND_MORTAL(9); 4880 mPUSHi(tmbuf.tm_sec); 4881 mPUSHi(tmbuf.tm_min); 4882 mPUSHi(tmbuf.tm_hour); 4883 mPUSHi(tmbuf.tm_mday); 4884 mPUSHi(tmbuf.tm_mon); 4885 mPUSHn(tmbuf.tm_year); 4886 mPUSHi(tmbuf.tm_wday); 4887 mPUSHi(tmbuf.tm_yday); 4888 mPUSHi(tmbuf.tm_isdst); 4889 } 4890 RETURN; 4891 } 4892 4893 PP(pp_alarm) 4894 { 4895 #ifdef HAS_ALARM 4896 dSP; dTARGET; 4897 /* alarm() takes an unsigned int number of seconds, and return the 4898 * unsigned int number of seconds remaining in the previous alarm 4899 * (alarms don't stack). Therefore negative return values are not 4900 * possible. */ 4901 int anum = POPi; 4902 if (anum < 0) { 4903 /* Note that while the C library function alarm() as such has 4904 * no errors defined (or in other words, properly behaving client 4905 * code shouldn't expect any), alarm() being obsoleted by 4906 * setitimer() and often being implemented in terms of 4907 * setitimer(), can fail. */ 4908 /* diag_listed_as: %s() with negative argument */ 4909 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), 4910 "alarm() with negative argument"); 4911 SETERRNO(EINVAL, LIB_INVARG); 4912 RETPUSHUNDEF; 4913 } 4914 else { 4915 unsigned int retval = alarm(anum); 4916 if ((int)retval < 0) /* Strictly speaking "cannot happen". */ 4917 RETPUSHUNDEF; 4918 PUSHu(retval); 4919 RETURN; 4920 } 4921 #else 4922 DIE(aTHX_ PL_no_func, "alarm"); 4923 #endif 4924 } 4925 4926 PP(pp_sleep) 4927 { 4928 dSP; dTARGET; 4929 Time_t lasttime; 4930 Time_t when; 4931 4932 (void)time(&lasttime); 4933 if (MAXARG < 1 || (!TOPs && !POPs)) 4934 PerlProc_pause(); 4935 else { 4936 const I32 duration = POPi; 4937 if (duration < 0) { 4938 /* diag_listed_as: %s() with negative argument */ 4939 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), 4940 "sleep() with negative argument"); 4941 SETERRNO(EINVAL, LIB_INVARG); 4942 XPUSHs(&PL_sv_zero); 4943 RETURN; 4944 } else { 4945 PerlProc_sleep((unsigned int)duration); 4946 } 4947 } 4948 (void)time(&when); 4949 XPUSHu((UV)(when - lasttime)); 4950 RETURN; 4951 } 4952 4953 /* Shared memory. */ 4954 /* Merged with some message passing. */ 4955 4956 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */ 4957 4958 PP(pp_shmwrite) 4959 { 4960 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 4961 dSP; dMARK; dTARGET; 4962 const int op_type = PL_op->op_type; 4963 I32 value; 4964 4965 switch (op_type) { 4966 case OP_MSGSND: 4967 value = (I32)(do_msgsnd(MARK, SP) >= 0); 4968 break; 4969 case OP_MSGRCV: 4970 value = (I32)(do_msgrcv(MARK, SP) >= 0); 4971 break; 4972 case OP_SEMOP: 4973 value = (I32)(do_semop(MARK, SP) >= 0); 4974 break; 4975 default: 4976 value = (I32)(do_shmio(op_type, MARK, SP) >= 0); 4977 break; 4978 } 4979 4980 SP = MARK; 4981 PUSHi(value); 4982 RETURN; 4983 #else 4984 return Perl_pp_semget(aTHX); 4985 #endif 4986 } 4987 4988 /* Semaphores. */ 4989 4990 /* also used for: pp_msgget() pp_shmget() */ 4991 4992 PP(pp_semget) 4993 { 4994 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 4995 dSP; dMARK; dTARGET; 4996 const int anum = do_ipcget(PL_op->op_type, MARK, SP); 4997 SP = MARK; 4998 if (anum == -1) 4999 RETPUSHUNDEF; 5000 PUSHi(anum); 5001 RETURN; 5002 #else 5003 DIE(aTHX_ "System V IPC is not implemented on this machine"); 5004 #endif 5005 } 5006 5007 /* also used for: pp_msgctl() pp_shmctl() */ 5008 5009 PP(pp_semctl) 5010 { 5011 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 5012 dSP; dMARK; dTARGET; 5013 const int anum = do_ipcctl(PL_op->op_type, MARK, SP); 5014 SP = MARK; 5015 if (anum == -1) 5016 RETPUSHUNDEF; 5017 if (anum != 0) { 5018 PUSHi(anum); 5019 } 5020 else { 5021 PUSHp(zero_but_true, ZBTLEN); 5022 } 5023 RETURN; 5024 #else 5025 return Perl_pp_semget(aTHX); 5026 #endif 5027 } 5028 5029 /* I can't const this further without getting warnings about the types of 5030 various arrays passed in from structures. */ 5031 static SV * 5032 S_space_join_names_mortal(pTHX_ char *const *array) 5033 { 5034 SV *target; 5035 5036 if (array && *array) { 5037 target = newSVpvs_flags("", SVs_TEMP); 5038 while (1) { 5039 sv_catpv(target, *array); 5040 if (!*++array) 5041 break; 5042 sv_catpvs(target, " "); 5043 } 5044 } else { 5045 target = sv_mortalcopy(&PL_sv_no); 5046 } 5047 return target; 5048 } 5049 5050 /* Get system info. */ 5051 5052 /* also used for: pp_ghbyaddr() pp_ghbyname() */ 5053 5054 PP(pp_ghostent) 5055 { 5056 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) 5057 dSP; 5058 I32 which = PL_op->op_type; 5059 char **elem; 5060 SV *sv; 5061 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ 5062 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); 5063 struct hostent *gethostbyname(Netdb_name_t); 5064 struct hostent *gethostent(void); 5065 #endif 5066 struct hostent *hent = NULL; 5067 unsigned long len; 5068 5069 EXTEND(SP, 10); 5070 if (which == OP_GHBYNAME) { 5071 #ifdef HAS_GETHOSTBYNAME 5072 const char* const name = POPpbytex; 5073 hent = PerlSock_gethostbyname(name); 5074 #else 5075 DIE(aTHX_ PL_no_sock_func, "gethostbyname"); 5076 #endif 5077 } 5078 else if (which == OP_GHBYADDR) { 5079 #ifdef HAS_GETHOSTBYADDR 5080 const int addrtype = POPi; 5081 SV * const addrsv = POPs; 5082 STRLEN addrlen; 5083 const char *addr = (char *)SvPVbyte(addrsv, addrlen); 5084 5085 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); 5086 #else 5087 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr"); 5088 #endif 5089 } 5090 else 5091 #ifdef HAS_GETHOSTENT 5092 hent = PerlSock_gethostent(); 5093 #else 5094 DIE(aTHX_ PL_no_sock_func, "gethostent"); 5095 #endif 5096 5097 #ifdef HOST_NOT_FOUND 5098 if (!hent) { 5099 #ifdef USE_REENTRANT_API 5100 # ifdef USE_GETHOSTENT_ERRNO 5101 h_errno = PL_reentrant_buffer->_gethostent_errno; 5102 # endif 5103 #endif 5104 STATUS_UNIX_SET(h_errno); 5105 } 5106 #endif 5107 5108 if (GIMME_V != G_LIST) { 5109 PUSHs(sv = sv_newmortal()); 5110 if (hent) { 5111 if (which == OP_GHBYNAME) { 5112 if (hent->h_addr) { 5113 sv_upgrade(sv, SVt_PV); 5114 sv_setpvn_fresh(sv, hent->h_addr, hent->h_length); 5115 } 5116 } 5117 else 5118 sv_setpv(sv, (char*)hent->h_name); 5119 } 5120 RETURN; 5121 } 5122 5123 if (hent) { 5124 mPUSHs(newSVpv((char*)hent->h_name, 0)); 5125 PUSHs(space_join_names_mortal(hent->h_aliases)); 5126 mPUSHi(hent->h_addrtype); 5127 len = hent->h_length; 5128 mPUSHi(len); 5129 #ifdef h_addr 5130 for (elem = hent->h_addr_list; elem && *elem; elem++) { 5131 mXPUSHp(*elem, len); 5132 } 5133 #else 5134 if (hent->h_addr) 5135 mPUSHp(hent->h_addr, len); 5136 else 5137 PUSHs(sv_mortalcopy(&PL_sv_no)); 5138 #endif /* h_addr */ 5139 } 5140 RETURN; 5141 #else 5142 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5143 #endif 5144 } 5145 5146 /* also used for: pp_gnbyaddr() pp_gnbyname() */ 5147 5148 PP(pp_gnetent) 5149 { 5150 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) 5151 dSP; 5152 I32 which = PL_op->op_type; 5153 SV *sv; 5154 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ 5155 struct netent *getnetbyaddr(Netdb_net_t, int); 5156 struct netent *getnetbyname(Netdb_name_t); 5157 struct netent *getnetent(void); 5158 #endif 5159 struct netent *nent; 5160 5161 if (which == OP_GNBYNAME){ 5162 #ifdef HAS_GETNETBYNAME 5163 const char * const name = POPpbytex; 5164 nent = PerlSock_getnetbyname(name); 5165 #else 5166 DIE(aTHX_ PL_no_sock_func, "getnetbyname"); 5167 #endif 5168 } 5169 else if (which == OP_GNBYADDR) { 5170 #ifdef HAS_GETNETBYADDR 5171 const int addrtype = POPi; 5172 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu; 5173 nent = PerlSock_getnetbyaddr(addr, addrtype); 5174 #else 5175 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); 5176 #endif 5177 } 5178 else 5179 #ifdef HAS_GETNETENT 5180 nent = PerlSock_getnetent(); 5181 #else 5182 DIE(aTHX_ PL_no_sock_func, "getnetent"); 5183 #endif 5184 5185 #ifdef HOST_NOT_FOUND 5186 if (!nent) { 5187 #ifdef USE_REENTRANT_API 5188 # ifdef USE_GETNETENT_ERRNO 5189 h_errno = PL_reentrant_buffer->_getnetent_errno; 5190 # endif 5191 #endif 5192 STATUS_UNIX_SET(h_errno); 5193 } 5194 #endif 5195 5196 EXTEND(SP, 4); 5197 if (GIMME_V != G_LIST) { 5198 PUSHs(sv = sv_newmortal()); 5199 if (nent) { 5200 if (which == OP_GNBYNAME) 5201 sv_setiv(sv, (IV)nent->n_net); 5202 else 5203 sv_setpv(sv, nent->n_name); 5204 } 5205 RETURN; 5206 } 5207 5208 if (nent) { 5209 mPUSHs(newSVpv(nent->n_name, 0)); 5210 PUSHs(space_join_names_mortal(nent->n_aliases)); 5211 mPUSHi(nent->n_addrtype); 5212 mPUSHi(nent->n_net); 5213 } 5214 5215 RETURN; 5216 #else 5217 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5218 #endif 5219 } 5220 5221 5222 /* also used for: pp_gpbyname() pp_gpbynumber() */ 5223 5224 PP(pp_gprotoent) 5225 { 5226 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) 5227 dSP; 5228 I32 which = PL_op->op_type; 5229 SV *sv; 5230 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ 5231 struct protoent *getprotobyname(Netdb_name_t); 5232 struct protoent *getprotobynumber(int); 5233 struct protoent *getprotoent(void); 5234 #endif 5235 struct protoent *pent; 5236 5237 if (which == OP_GPBYNAME) { 5238 #ifdef HAS_GETPROTOBYNAME 5239 const char* const name = POPpbytex; 5240 pent = PerlSock_getprotobyname(name); 5241 #else 5242 DIE(aTHX_ PL_no_sock_func, "getprotobyname"); 5243 #endif 5244 } 5245 else if (which == OP_GPBYNUMBER) { 5246 #ifdef HAS_GETPROTOBYNUMBER 5247 const int number = POPi; 5248 pent = PerlSock_getprotobynumber(number); 5249 #else 5250 DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); 5251 #endif 5252 } 5253 else 5254 #ifdef HAS_GETPROTOENT 5255 pent = PerlSock_getprotoent(); 5256 #else 5257 DIE(aTHX_ PL_no_sock_func, "getprotoent"); 5258 #endif 5259 5260 EXTEND(SP, 3); 5261 if (GIMME_V != G_LIST) { 5262 PUSHs(sv = sv_newmortal()); 5263 if (pent) { 5264 if (which == OP_GPBYNAME) 5265 sv_setiv(sv, (IV)pent->p_proto); 5266 else 5267 sv_setpv(sv, pent->p_name); 5268 } 5269 RETURN; 5270 } 5271 5272 if (pent) { 5273 mPUSHs(newSVpv(pent->p_name, 0)); 5274 PUSHs(space_join_names_mortal(pent->p_aliases)); 5275 mPUSHi(pent->p_proto); 5276 } 5277 5278 RETURN; 5279 #else 5280 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5281 #endif 5282 } 5283 5284 5285 /* also used for: pp_gsbyname() pp_gsbyport() */ 5286 5287 PP(pp_gservent) 5288 { 5289 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) 5290 dSP; 5291 I32 which = PL_op->op_type; 5292 SV *sv; 5293 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ 5294 struct servent *getservbyname(Netdb_name_t, Netdb_name_t); 5295 struct servent *getservbyport(int, Netdb_name_t); 5296 struct servent *getservent(void); 5297 #endif 5298 struct servent *sent; 5299 5300 if (which == OP_GSBYNAME) { 5301 #ifdef HAS_GETSERVBYNAME 5302 const char * const proto = POPpbytex; 5303 const char * const name = POPpbytex; 5304 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto); 5305 #else 5306 DIE(aTHX_ PL_no_sock_func, "getservbyname"); 5307 #endif 5308 } 5309 else if (which == OP_GSBYPORT) { 5310 #ifdef HAS_GETSERVBYPORT 5311 const char * const proto = POPpbytex; 5312 unsigned short port = (unsigned short)POPu; 5313 port = PerlSock_htons(port); 5314 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto); 5315 #else 5316 DIE(aTHX_ PL_no_sock_func, "getservbyport"); 5317 #endif 5318 } 5319 else 5320 #ifdef HAS_GETSERVENT 5321 sent = PerlSock_getservent(); 5322 #else 5323 DIE(aTHX_ PL_no_sock_func, "getservent"); 5324 #endif 5325 5326 EXTEND(SP, 4); 5327 if (GIMME_V != G_LIST) { 5328 PUSHs(sv = sv_newmortal()); 5329 if (sent) { 5330 if (which == OP_GSBYNAME) { 5331 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port)); 5332 } 5333 else 5334 sv_setpv(sv, sent->s_name); 5335 } 5336 RETURN; 5337 } 5338 5339 if (sent) { 5340 mPUSHs(newSVpv(sent->s_name, 0)); 5341 PUSHs(space_join_names_mortal(sent->s_aliases)); 5342 mPUSHi(PerlSock_ntohs(sent->s_port)); 5343 mPUSHs(newSVpv(sent->s_proto, 0)); 5344 } 5345 5346 RETURN; 5347 #else 5348 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5349 #endif 5350 } 5351 5352 5353 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */ 5354 5355 PP(pp_shostent) 5356 { 5357 dSP; 5358 const int stayopen = TOPi; 5359 switch(PL_op->op_type) { 5360 case OP_SHOSTENT: 5361 #ifdef HAS_SETHOSTENT 5362 PerlSock_sethostent(stayopen); 5363 #else 5364 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5365 #endif 5366 break; 5367 case OP_SNETENT: 5368 #ifdef HAS_SETNETENT 5369 PerlSock_setnetent(stayopen); 5370 #else 5371 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5372 #endif 5373 break; 5374 case OP_SPROTOENT: 5375 #ifdef HAS_SETPROTOENT 5376 PerlSock_setprotoent(stayopen); 5377 #else 5378 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5379 #endif 5380 break; 5381 case OP_SSERVENT: 5382 #ifdef HAS_SETSERVENT 5383 PerlSock_setservent(stayopen); 5384 #else 5385 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5386 #endif 5387 break; 5388 } 5389 RETSETYES; 5390 } 5391 5392 5393 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent() 5394 * pp_eservent() pp_sgrent() pp_spwent() */ 5395 5396 PP(pp_ehostent) 5397 { 5398 dSP; 5399 switch(PL_op->op_type) { 5400 case OP_EHOSTENT: 5401 #ifdef HAS_ENDHOSTENT 5402 PerlSock_endhostent(); 5403 #else 5404 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5405 #endif 5406 break; 5407 case OP_ENETENT: 5408 #ifdef HAS_ENDNETENT 5409 PerlSock_endnetent(); 5410 #else 5411 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5412 #endif 5413 break; 5414 case OP_EPROTOENT: 5415 #ifdef HAS_ENDPROTOENT 5416 PerlSock_endprotoent(); 5417 #else 5418 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5419 #endif 5420 break; 5421 case OP_ESERVENT: 5422 #ifdef HAS_ENDSERVENT 5423 PerlSock_endservent(); 5424 #else 5425 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5426 #endif 5427 break; 5428 case OP_SGRENT: 5429 #if defined(HAS_GROUP) && defined(HAS_SETGRENT) 5430 setgrent(); 5431 #else 5432 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5433 #endif 5434 break; 5435 case OP_EGRENT: 5436 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) 5437 endgrent(); 5438 #else 5439 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5440 #endif 5441 break; 5442 case OP_SPWENT: 5443 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) 5444 setpwent(); 5445 #else 5446 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5447 #endif 5448 break; 5449 case OP_EPWENT: 5450 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) 5451 endpwent(); 5452 #else 5453 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5454 #endif 5455 break; 5456 } 5457 EXTEND(SP,1); 5458 RETPUSHYES; 5459 } 5460 5461 5462 /* also used for: pp_gpwnam() pp_gpwuid() */ 5463 5464 PP(pp_gpwent) 5465 { 5466 #ifdef HAS_PASSWD 5467 dSP; 5468 I32 which = PL_op->op_type; 5469 SV *sv; 5470 struct passwd *pwent = NULL; 5471 /* 5472 * We currently support only the SysV getsp* shadow password interface. 5473 * The interface is declared in <shadow.h> and often one needs to link 5474 * with -lsecurity or some such. 5475 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux. 5476 * (and SCO?) 5477 * 5478 * AIX getpwnam() is clever enough to return the encrypted password 5479 * only if the caller (euid?) is root. 5480 * 5481 * There are at least three other shadow password APIs. Many platforms 5482 * seem to contain more than one interface for accessing the shadow 5483 * password databases, possibly for compatibility reasons. 5484 * The getsp*() is by far he simplest one, the other two interfaces 5485 * are much more complicated, but also very similar to each other. 5486 * 5487 * <sys/types.h> 5488 * <sys/security.h> 5489 * <prot.h> 5490 * struct pr_passwd *getprpw*(); 5491 * The password is in 5492 * char getprpw*(...).ufld.fd_encrypt[] 5493 * Mention HAS_GETPRPWNAM here so that Configure probes for it. 5494 * 5495 * <sys/types.h> 5496 * <sys/security.h> 5497 * <prot.h> 5498 * struct es_passwd *getespw*(); 5499 * The password is in 5500 * char *(getespw*(...).ufld.fd_encrypt) 5501 * Mention HAS_GETESPWNAM here so that Configure probes for it. 5502 * 5503 * <userpw.h> (AIX) 5504 * struct userpw *getuserpw(); 5505 * The password is in 5506 * char *(getuserpw(...)).spw_upw_passwd 5507 * (but the de facto standard getpwnam() should work okay) 5508 * 5509 * Mention I_PROT here so that Configure probes for it. 5510 * 5511 * In HP-UX for getprpw*() the manual page claims that one should include 5512 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed 5513 * if one includes <shadow.h> as that includes <hpsecurity.h>, 5514 * and pp_sys.c already includes <shadow.h> if there is such. 5515 * 5516 * Note that <sys/security.h> is already probed for, but currently 5517 * it is only included in special cases. 5518 * 5519 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be 5520 * the preferred interface, even though also the getprpw*() interface 5521 * is available) one needs to link with -lsecurity -ldb -laud -lm. 5522 * One also needs to call set_auth_parameters() in main() before 5523 * doing anything else, whether one is using getespw*() or getprpw*(). 5524 * 5525 * Note that accessing the shadow databases can be magnitudes 5526 * slower than accessing the standard databases. 5527 * 5528 * --jhi 5529 */ 5530 5531 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API) 5532 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r(): 5533 * the pw_comment is left uninitialized. */ 5534 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL; 5535 # endif 5536 5537 switch (which) { 5538 case OP_GPWNAM: 5539 { 5540 const char* const name = POPpbytex; 5541 GETPWNAM_LOCK; 5542 pwent = getpwnam(name); 5543 GETPWNAM_UNLOCK; 5544 } 5545 break; 5546 case OP_GPWUID: 5547 { 5548 Uid_t uid = POPi; 5549 GETPWUID_LOCK; 5550 pwent = getpwuid(uid); 5551 GETPWUID_UNLOCK; 5552 } 5553 break; 5554 case OP_GPWENT: 5555 # ifdef HAS_GETPWENT 5556 pwent = getpwent(); 5557 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ 5558 if (pwent) { 5559 GETPWNAM_LOCK; 5560 pwent = getpwnam(pwent->pw_name); 5561 GETPWNAM_UNLOCK; 5562 } 5563 #endif 5564 # else 5565 DIE(aTHX_ PL_no_func, "getpwent"); 5566 # endif 5567 break; 5568 } 5569 5570 EXTEND(SP, 10); 5571 if (GIMME_V != G_LIST) { 5572 PUSHs(sv = sv_newmortal()); 5573 if (pwent) { 5574 if (which == OP_GPWNAM) 5575 sv_setuid(sv, pwent->pw_uid); 5576 else 5577 sv_setpv(sv, pwent->pw_name); 5578 } 5579 RETURN; 5580 } 5581 5582 if (pwent) { 5583 mPUSHs(newSVpv(pwent->pw_name, 0)); 5584 5585 sv = newSViv(0); 5586 mPUSHs(sv); 5587 /* If we have getspnam(), we try to dig up the shadow 5588 * password. If we are underprivileged, the shadow 5589 * interface will set the errno to EACCES or similar, 5590 * and return a null pointer. If this happens, we will 5591 * use the dummy password (usually "*" or "x") from the 5592 * standard password database. 5593 * 5594 * In theory we could skip the shadow call completely 5595 * if euid != 0 but in practice we cannot know which 5596 * security measures are guarding the shadow databases 5597 * on a random platform. 5598 * 5599 * Resist the urge to use additional shadow interfaces. 5600 * Divert the urge to writing an extension instead. 5601 * 5602 * --jhi */ 5603 /* Some AIX setups falsely(?) detect some getspnam(), which 5604 * has a different API than the Solaris/IRIX one. */ 5605 # if defined(HAS_GETSPNAM) && !defined(_AIX) 5606 { 5607 const struct spwd * spwent; 5608 dSAVE_ERRNO; 5609 GETSPNAM_LOCK; 5610 spwent = getspnam(pwent->pw_name); 5611 /* Save and restore errno so that 5612 * underprivileged attempts seem 5613 * to have never made the unsuccessful 5614 * attempt to retrieve the shadow password. */ 5615 RESTORE_ERRNO; 5616 if (spwent && spwent->sp_pwdp) 5617 sv_setpv(sv, spwent->sp_pwdp); 5618 GETSPNAM_UNLOCK; 5619 } 5620 # endif 5621 # ifdef PWPASSWD 5622 if (!SvPOK(sv)) /* Use the standard password, then. */ 5623 sv_setpv(sv, pwent->pw_passwd); 5624 # endif 5625 5626 /* passwd is tainted because user himself can diddle with it. 5627 * admittedly not much and in a very limited way, but nevertheless. */ 5628 SvTAINTED_on(sv); 5629 5630 sv_setuid(PUSHmortal, pwent->pw_uid); 5631 sv_setgid(PUSHmortal, pwent->pw_gid); 5632 5633 /* pw_change, pw_quota, and pw_age are mutually exclusive-- 5634 * because of the poor interface of the Perl getpw*(), 5635 * not because there's some standard/convention saying so. 5636 * A better interface would have been to return a hash, 5637 * but we are accursed by our history, alas. --jhi. */ 5638 # ifdef PWCHANGE 5639 mPUSHi(pwent->pw_change); 5640 # elif defined(PWQUOTA) 5641 mPUSHi(pwent->pw_quota); 5642 # elif defined(PWAGE) 5643 mPUSHs(newSVpv(pwent->pw_age, 0)); 5644 # else 5645 /* I think that you can never get this compiled, but just in case. */ 5646 PUSHs(sv_mortalcopy(&PL_sv_no)); 5647 # endif 5648 5649 /* pw_class and pw_comment are mutually exclusive--. 5650 * see the above note for pw_change, pw_quota, and pw_age. */ 5651 # ifdef PWCLASS 5652 mPUSHs(newSVpv(pwent->pw_class, 0)); 5653 # elif defined(PWCOMMENT) 5654 mPUSHs(newSVpv(pwent->pw_comment, 0)); 5655 # else 5656 /* I think that you can never get this compiled, but just in case. */ 5657 PUSHs(sv_mortalcopy(&PL_sv_no)); 5658 # endif 5659 5660 # ifdef PWGECOS 5661 PUSHs(sv = newSVpvn_flags(pwent->pw_gecos, 5662 pwent->pw_gecos == NULL ? 0 : strlen(pwent->pw_gecos), 5663 SVs_TEMP)); 5664 # else 5665 PUSHs(sv = sv_mortalcopy(&PL_sv_no)); 5666 # endif 5667 /* pw_gecos is tainted because user himself can diddle with it. */ 5668 SvTAINTED_on(sv); 5669 5670 mPUSHs(newSVpv(pwent->pw_dir, 0)); 5671 5672 PUSHs(sv = newSVpvn_flags(pwent->pw_shell, 5673 pwent->pw_shell == NULL ? 0 : strlen(pwent->pw_shell), 5674 SVs_TEMP)); 5675 /* pw_shell is tainted because user himself can diddle with it. */ 5676 SvTAINTED_on(sv); 5677 5678 # ifdef PWEXPIRE 5679 mPUSHi(pwent->pw_expire); 5680 # endif 5681 } 5682 RETURN; 5683 #else 5684 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5685 #endif 5686 } 5687 5688 5689 /* also used for: pp_ggrgid() pp_ggrnam() */ 5690 5691 PP(pp_ggrent) 5692 { 5693 #ifdef HAS_GROUP 5694 dSP; 5695 const I32 which = PL_op->op_type; 5696 const struct group *grent; 5697 5698 if (which == OP_GGRNAM) { 5699 const char* const name = POPpbytex; 5700 grent = (const struct group *)getgrnam(name); 5701 } 5702 else if (which == OP_GGRGID) { 5703 #if Gid_t_sign == 1 5704 const Gid_t gid = POPu; 5705 #elif Gid_t_sign == -1 5706 const Gid_t gid = POPi; 5707 #else 5708 # error "Unexpected Gid_t_sign" 5709 #endif 5710 grent = (const struct group *)getgrgid(gid); 5711 } 5712 else 5713 #ifdef HAS_GETGRENT 5714 grent = (struct group *)getgrent(); 5715 #else 5716 DIE(aTHX_ PL_no_func, "getgrent"); 5717 #endif 5718 5719 EXTEND(SP, 4); 5720 if (GIMME_V != G_LIST) { 5721 SV * const sv = sv_newmortal(); 5722 5723 PUSHs(sv); 5724 if (grent) { 5725 if (which == OP_GGRNAM) 5726 sv_setgid(sv, grent->gr_gid); 5727 else 5728 sv_setpv(sv, grent->gr_name); 5729 } 5730 RETURN; 5731 } 5732 5733 if (grent) { 5734 mPUSHs(newSVpv(grent->gr_name, 0)); 5735 5736 #ifdef GRPASSWD 5737 mPUSHs(newSVpv(grent->gr_passwd, 0)); 5738 #else 5739 PUSHs(sv_mortalcopy(&PL_sv_no)); 5740 #endif 5741 5742 sv_setgid(PUSHmortal, grent->gr_gid); 5743 5744 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API)) 5745 /* In UNICOS/mk (_CRAYMPP) the multithreading 5746 * versions (getgrnam_r, getgrgid_r) 5747 * seem to return an illegal pointer 5748 * as the group members list, gr_mem. 5749 * getgrent() doesn't even have a _r version 5750 * but the gr_mem is poisonous anyway. 5751 * So yes, you cannot get the list of group 5752 * members if building multithreaded in UNICOS/mk. */ 5753 PUSHs(space_join_names_mortal(grent->gr_mem)); 5754 #endif 5755 } 5756 5757 RETURN; 5758 #else 5759 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5760 #endif 5761 } 5762 5763 PP(pp_getlogin) 5764 { 5765 #ifdef HAS_GETLOGIN 5766 dSP; dTARGET; 5767 char *tmps; 5768 EXTEND(SP, 1); 5769 if (!(tmps = PerlProc_getlogin())) 5770 RETPUSHUNDEF; 5771 sv_setpv_mg(TARG, tmps); 5772 PUSHs(TARG); 5773 RETURN; 5774 #else 5775 DIE(aTHX_ PL_no_func, "getlogin"); 5776 #endif 5777 } 5778 5779 /* Miscellaneous. */ 5780 5781 PP(pp_syscall) 5782 { 5783 #ifdef HAS_SYSCALL 5784 dSP; dMARK; dORIGMARK; dTARGET; 5785 I32 items = SP - MARK; 5786 unsigned long a[20]; 5787 I32 i = 0; 5788 IV retval = -1; 5789 5790 if (TAINTING_get) { 5791 while (++MARK <= SP) { 5792 if (SvTAINTED(*MARK)) { 5793 TAINT; 5794 break; 5795 } 5796 } 5797 MARK = ORIGMARK; 5798 TAINT_PROPER("syscall"); 5799 } 5800 5801 /* This probably won't work on machines where sizeof(long) != sizeof(int) 5802 * or where sizeof(long) != sizeof(char*). But such machines will 5803 * not likely have syscall implemented either, so who cares? 5804 */ 5805 while (++MARK <= SP) { 5806 if (SvNIOK(*MARK) || !i) 5807 a[i++] = SvIV(*MARK); 5808 else if (*MARK == &PL_sv_undef) 5809 a[i++] = 0; 5810 else 5811 a[i++] = (unsigned long)SvPV_force_nolen(*MARK); 5812 if (i > 15) 5813 break; 5814 } 5815 switch (items) { 5816 default: 5817 DIE(aTHX_ "Too many args to syscall"); 5818 case 0: 5819 DIE(aTHX_ "Too few args to syscall"); 5820 case 1: 5821 retval = syscall(a[0]); 5822 break; 5823 case 2: 5824 retval = syscall(a[0],a[1]); 5825 break; 5826 case 3: 5827 retval = syscall(a[0],a[1],a[2]); 5828 break; 5829 case 4: 5830 retval = syscall(a[0],a[1],a[2],a[3]); 5831 break; 5832 case 5: 5833 retval = syscall(a[0],a[1],a[2],a[3],a[4]); 5834 break; 5835 case 6: 5836 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]); 5837 break; 5838 case 7: 5839 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); 5840 break; 5841 case 8: 5842 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); 5843 break; 5844 } 5845 SP = ORIGMARK; 5846 PUSHi(retval); 5847 RETURN; 5848 #else 5849 DIE(aTHX_ PL_no_func, "syscall"); 5850 #endif 5851 } 5852 5853 #ifdef FCNTL_EMULATE_FLOCK 5854 5855 /* XXX Emulate flock() with fcntl(). 5856 What's really needed is a good file locking module. 5857 */ 5858 5859 static int 5860 fcntl_emulate_flock(int fd, int operation) 5861 { 5862 int res; 5863 struct flock flock; 5864 5865 switch (operation & ~LOCK_NB) { 5866 case LOCK_SH: 5867 flock.l_type = F_RDLCK; 5868 break; 5869 case LOCK_EX: 5870 flock.l_type = F_WRLCK; 5871 break; 5872 case LOCK_UN: 5873 flock.l_type = F_UNLCK; 5874 break; 5875 default: 5876 errno = EINVAL; 5877 return -1; 5878 } 5879 flock.l_whence = SEEK_SET; 5880 flock.l_start = flock.l_len = (Off_t)0; 5881 5882 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); 5883 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES))) 5884 errno = EWOULDBLOCK; 5885 return res; 5886 } 5887 5888 #endif /* FCNTL_EMULATE_FLOCK */ 5889 5890 #ifdef LOCKF_EMULATE_FLOCK 5891 5892 /* XXX Emulate flock() with lockf(). This is just to increase 5893 portability of scripts. The calls are not completely 5894 interchangeable. What's really needed is a good file 5895 locking module. 5896 */ 5897 5898 /* The lockf() constants might have been defined in <unistd.h>. 5899 Unfortunately, <unistd.h> causes troubles on some mixed 5900 (BSD/POSIX) systems, such as SunOS 4.1.3. 5901 5902 Further, the lockf() constants aren't POSIX, so they might not be 5903 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll 5904 just stick in the SVID values and be done with it. Sigh. 5905 */ 5906 5907 # ifndef F_ULOCK 5908 # define F_ULOCK 0 /* Unlock a previously locked region */ 5909 # endif 5910 # ifndef F_LOCK 5911 # define F_LOCK 1 /* Lock a region for exclusive use */ 5912 # endif 5913 # ifndef F_TLOCK 5914 # define F_TLOCK 2 /* Test and lock a region for exclusive use */ 5915 # endif 5916 # ifndef F_TEST 5917 # define F_TEST 3 /* Test a region for other processes locks */ 5918 # endif 5919 5920 static int 5921 lockf_emulate_flock(int fd, int operation) 5922 { 5923 int i; 5924 Off_t pos; 5925 dSAVE_ERRNO; 5926 5927 /* flock locks entire file so for lockf we need to do the same */ 5928 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ 5929 if (pos > 0) /* is seekable and needs to be repositioned */ 5930 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) 5931 pos = -1; /* seek failed, so don't seek back afterwards */ 5932 RESTORE_ERRNO; 5933 5934 switch (operation) { 5935 5936 /* LOCK_SH - get a shared lock */ 5937 case LOCK_SH: 5938 /* LOCK_EX - get an exclusive lock */ 5939 case LOCK_EX: 5940 i = lockf (fd, F_LOCK, 0); 5941 break; 5942 5943 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */ 5944 case LOCK_SH|LOCK_NB: 5945 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */ 5946 case LOCK_EX|LOCK_NB: 5947 i = lockf (fd, F_TLOCK, 0); 5948 if (i == -1) 5949 if ((errno == EAGAIN) || (errno == EACCES)) 5950 errno = EWOULDBLOCK; 5951 break; 5952 5953 /* LOCK_UN - unlock (non-blocking is a no-op) */ 5954 case LOCK_UN: 5955 case LOCK_UN|LOCK_NB: 5956 i = lockf (fd, F_ULOCK, 0); 5957 break; 5958 5959 /* Default - can't decipher operation */ 5960 default: 5961 i = -1; 5962 errno = EINVAL; 5963 break; 5964 } 5965 5966 if (pos > 0) /* need to restore position of the handle */ 5967 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */ 5968 5969 return (i); 5970 } 5971 5972 #endif /* LOCKF_EMULATE_FLOCK */ 5973 5974 /* 5975 * ex: set ts=8 sts=4 sw=4 et: 5976 */ 5977