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