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