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 (SvPOK(errsv) && SvCUR(errsv)) { 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( do_tell(gv) ); 2183 #else 2184 PUSHi( 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 sv = sv_2mortal(newSV(257)); 2767 (void)SvPOK_only(sv); 2768 len = 256; 2769 SvCUR_set(sv, len); 2770 *SvEND(sv) ='\0'; 2771 fd = PerlIO_fileno(IoIFP(io)); 2772 if (fd < 0) 2773 goto nuts; 2774 switch (optype) { 2775 case OP_GETSOCKNAME: 2776 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) 2777 goto nuts2; 2778 break; 2779 case OP_GETPEERNAME: 2780 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) 2781 goto nuts2; 2782 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS) 2783 { 2784 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"; 2785 /* If the call succeeded, make sure we don't have a zeroed port/addr */ 2786 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && 2787 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, 2788 sizeof(u_short) + sizeof(struct in_addr))) { 2789 goto nuts2; 2790 } 2791 } 2792 #endif 2793 break; 2794 } 2795 #ifdef BOGUS_GETNAME_RETURN 2796 /* Interactive Unix, getpeername() and getsockname() 2797 does not return valid namelen */ 2798 if (len == BOGUS_GETNAME_RETURN) 2799 len = sizeof(struct sockaddr); 2800 #endif 2801 SvCUR_set(sv, len); 2802 *SvEND(sv) ='\0'; 2803 PUSHs(sv); 2804 RETURN; 2805 2806 nuts: 2807 report_evil_fh(gv); 2808 SETERRNO(EBADF,SS_IVCHAN); 2809 nuts2: 2810 RETPUSHUNDEF; 2811 } 2812 2813 #endif 2814 2815 /* Stat calls. */ 2816 2817 /* also used for: pp_lstat() */ 2818 2819 PP(pp_stat) 2820 { 2821 dSP; 2822 GV *gv = NULL; 2823 IO *io = NULL; 2824 U8 gimme; 2825 I32 max = 13; 2826 SV* sv; 2827 2828 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1) 2829 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) { 2830 if (PL_op->op_type == OP_LSTAT) { 2831 if (gv != PL_defgv) { 2832 do_fstat_warning_check: 2833 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 2834 "lstat() on filehandle%s%" SVf, 2835 gv ? " " : "", 2836 SVfARG(gv 2837 ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) 2838 : &PL_sv_no)); 2839 } else if (PL_laststype != OP_LSTAT) 2840 /* diag_listed_as: The stat preceding %s wasn't an lstat */ 2841 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); 2842 } 2843 2844 if (gv == PL_defgv) { 2845 if (PL_laststatval < 0) 2846 SETERRNO(EBADF,RMS_IFI); 2847 } else { 2848 do_fstat_have_io: 2849 PL_laststype = OP_STAT; 2850 PL_statgv = gv ? gv : (GV *)io; 2851 SvPVCLEAR(PL_statname); 2852 if(gv) { 2853 io = GvIO(gv); 2854 } 2855 if (io) { 2856 if (IoIFP(io)) { 2857 int fd = PerlIO_fileno(IoIFP(io)); 2858 if (fd < 0) { 2859 report_evil_fh(gv); 2860 PL_laststatval = -1; 2861 SETERRNO(EBADF,RMS_IFI); 2862 } else { 2863 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); 2864 } 2865 } else if (IoDIRP(io)) { 2866 PL_laststatval = 2867 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); 2868 } else { 2869 report_evil_fh(gv); 2870 PL_laststatval = -1; 2871 SETERRNO(EBADF,RMS_IFI); 2872 } 2873 } else { 2874 report_evil_fh(gv); 2875 PL_laststatval = -1; 2876 SETERRNO(EBADF,RMS_IFI); 2877 } 2878 } 2879 2880 if (PL_laststatval < 0) { 2881 max = 0; 2882 } 2883 } 2884 else { 2885 const char *file; 2886 const char *temp; 2887 STRLEN len; 2888 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 2889 io = MUTABLE_IO(SvRV(sv)); 2890 if (PL_op->op_type == OP_LSTAT) 2891 goto do_fstat_warning_check; 2892 goto do_fstat_have_io; 2893 } 2894 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */ 2895 temp = SvPV_nomg_const(sv, len); 2896 sv_setpv(PL_statname, temp); 2897 PL_statgv = NULL; 2898 PL_laststype = PL_op->op_type; 2899 file = SvPV_nolen_const(PL_statname); 2900 if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) { 2901 PL_laststatval = -1; 2902 } 2903 else if (PL_op->op_type == OP_LSTAT) 2904 PL_laststatval = PerlLIO_lstat(file, &PL_statcache); 2905 else 2906 PL_laststatval = PerlLIO_stat(file, &PL_statcache); 2907 if (PL_laststatval < 0) { 2908 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { 2909 /* PL_warn_nl is constant */ 2910 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); 2911 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); 2912 GCC_DIAG_RESTORE_STMT; 2913 } 2914 max = 0; 2915 } 2916 } 2917 2918 gimme = GIMME_V; 2919 if (gimme != G_ARRAY) { 2920 if (gimme != G_VOID) 2921 XPUSHs(boolSV(max)); 2922 RETURN; 2923 } 2924 if (max) { 2925 EXTEND(SP, max); 2926 EXTEND_MORTAL(max); 2927 mPUSHi(PL_statcache.st_dev); 2928 { 2929 /* 2930 * We try to represent st_ino as a native IV or UV where 2931 * possible, but fall back to a decimal string where 2932 * necessary. The code to generate these decimal strings 2933 * is quite obtuse, because (a) we're portable to non-POSIX 2934 * platforms where st_ino might be signed; (b) we didn't 2935 * necessarily detect at Configure time whether st_ino is 2936 * signed; (c) we're portable to non-POSIX platforms where 2937 * ino_t isn't defined, so have no name for the type of 2938 * st_ino; and (d) sprintf() doesn't necessarily support 2939 * integers as large as st_ino. 2940 */ 2941 bool neg; 2942 Stat_t s; 2943 CLANG_DIAG_IGNORE_STMT(-Wtautological-compare); 2944 GCC_DIAG_IGNORE_STMT(-Wtype-limits); 2945 neg = PL_statcache.st_ino < 0; 2946 GCC_DIAG_RESTORE_STMT; 2947 CLANG_DIAG_RESTORE_STMT; 2948 if (neg) { 2949 s.st_ino = (IV)PL_statcache.st_ino; 2950 if (LIKELY(s.st_ino == PL_statcache.st_ino)) { 2951 mPUSHi(s.st_ino); 2952 } else { 2953 char buf[sizeof(s.st_ino)*3+1], *p; 2954 s.st_ino = PL_statcache.st_ino; 2955 for (p = buf + sizeof(buf); p != buf+1; ) { 2956 Stat_t t; 2957 t.st_ino = s.st_ino / 10; 2958 *--p = '0' + (int)(t.st_ino*10 - s.st_ino); 2959 s.st_ino = t.st_ino; 2960 } 2961 while (*p == '0') 2962 p++; 2963 *--p = '-'; 2964 mPUSHp(p, buf+sizeof(buf) - p); 2965 } 2966 } else { 2967 s.st_ino = (UV)PL_statcache.st_ino; 2968 if (LIKELY(s.st_ino == PL_statcache.st_ino)) { 2969 mPUSHu(s.st_ino); 2970 } else { 2971 char buf[sizeof(s.st_ino)*3], *p; 2972 s.st_ino = PL_statcache.st_ino; 2973 for (p = buf + sizeof(buf); p != buf; ) { 2974 Stat_t t; 2975 t.st_ino = s.st_ino / 10; 2976 *--p = '0' + (int)(s.st_ino - t.st_ino*10); 2977 s.st_ino = t.st_ino; 2978 } 2979 while (*p == '0') 2980 p++; 2981 mPUSHp(p, buf+sizeof(buf) - p); 2982 } 2983 } 2984 } 2985 mPUSHu(PL_statcache.st_mode); 2986 mPUSHu(PL_statcache.st_nlink); 2987 2988 sv_setuid(PUSHmortal, PL_statcache.st_uid); 2989 sv_setgid(PUSHmortal, PL_statcache.st_gid); 2990 2991 #ifdef USE_STAT_RDEV 2992 mPUSHi(PL_statcache.st_rdev); 2993 #else 2994 PUSHs(newSVpvs_flags("", SVs_TEMP)); 2995 #endif 2996 #if Off_t_size > IVSIZE 2997 mPUSHn(PL_statcache.st_size); 2998 #else 2999 mPUSHi(PL_statcache.st_size); 3000 #endif 3001 #ifdef BIG_TIME 3002 mPUSHn(PL_statcache.st_atime); 3003 mPUSHn(PL_statcache.st_mtime); 3004 mPUSHn(PL_statcache.st_ctime); 3005 #else 3006 mPUSHi(PL_statcache.st_atime); 3007 mPUSHi(PL_statcache.st_mtime); 3008 mPUSHi(PL_statcache.st_ctime); 3009 #endif 3010 #ifdef USE_STAT_BLOCKS 3011 mPUSHu(PL_statcache.st_blksize); 3012 mPUSHu(PL_statcache.st_blocks); 3013 #else 3014 PUSHs(newSVpvs_flags("", SVs_TEMP)); 3015 PUSHs(newSVpvs_flags("", SVs_TEMP)); 3016 #endif 3017 } 3018 RETURN; 3019 } 3020 3021 /* All filetest ops avoid manipulating the perl stack pointer in their main 3022 bodies (since commit d2c4d2d1e22d3125), and return using either 3023 S_ft_return_false() or S_ft_return_true(). These two helper functions are 3024 the only two which manipulate the perl stack. To ensure that no stack 3025 manipulation macros are used, the filetest ops avoid defining a local copy 3026 of the stack pointer with dSP. */ 3027 3028 /* If the next filetest is stacked up with this one 3029 (PL_op->op_private & OPpFT_STACKING), we leave 3030 the original argument on the stack for success, 3031 and skip the stacked operators on failure. 3032 The next few macros/functions take care of this. 3033 */ 3034 3035 static OP * 3036 S_ft_return_false(pTHX_ SV *ret) { 3037 OP *next = NORMAL; 3038 dSP; 3039 3040 if (PL_op->op_flags & OPf_REF) XPUSHs(ret); 3041 else SETs(ret); 3042 PUTBACK; 3043 3044 if (PL_op->op_private & OPpFT_STACKING) { 3045 while (next && OP_IS_FILETEST(next->op_type) 3046 && next->op_private & OPpFT_STACKED) 3047 next = next->op_next; 3048 } 3049 return next; 3050 } 3051 3052 PERL_STATIC_INLINE OP * 3053 S_ft_return_true(pTHX_ SV *ret) { 3054 dSP; 3055 if (PL_op->op_flags & OPf_REF) 3056 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret)); 3057 else if (!(PL_op->op_private & OPpFT_STACKING)) 3058 SETs(ret); 3059 PUTBACK; 3060 return NORMAL; 3061 } 3062 3063 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no) 3064 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef) 3065 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes) 3066 3067 #define tryAMAGICftest_MG(chr) STMT_START { \ 3068 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \ 3069 && PL_op->op_flags & OPf_KIDS) { \ 3070 OP *next = S_try_amagic_ftest(aTHX_ chr); \ 3071 if (next) return next; \ 3072 } \ 3073 } STMT_END 3074 3075 STATIC OP * 3076 S_try_amagic_ftest(pTHX_ char chr) { 3077 SV *const arg = *PL_stack_sp; 3078 3079 assert(chr != '?'); 3080 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); 3081 3082 if (SvAMAGIC(arg)) 3083 { 3084 const char tmpchr = chr; 3085 SV * const tmpsv = amagic_call(arg, 3086 newSVpvn_flags(&tmpchr, 1, SVs_TEMP), 3087 ftest_amg, AMGf_unary); 3088 3089 if (!tmpsv) 3090 return NULL; 3091 3092 return SvTRUE(tmpsv) 3093 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv); 3094 } 3095 return NULL; 3096 } 3097 3098 3099 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec() 3100 * pp_ftrwrite() */ 3101 3102 PP(pp_ftrread) 3103 { 3104 I32 result; 3105 /* Not const, because things tweak this below. Not bool, because there's 3106 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */ 3107 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) 3108 I32 use_access = PL_op->op_private & OPpFT_ACCESS; 3109 /* Giving some sort of initial value silences compilers. */ 3110 # ifdef R_OK 3111 int access_mode = R_OK; 3112 # else 3113 int access_mode = 0; 3114 # endif 3115 #else 3116 /* access_mode is never used, but leaving use_access in makes the 3117 conditional compiling below much clearer. */ 3118 I32 use_access = 0; 3119 #endif 3120 Mode_t stat_mode = S_IRUSR; 3121 3122 bool effective = FALSE; 3123 char opchar = '?'; 3124 3125 switch (PL_op->op_type) { 3126 case OP_FTRREAD: opchar = 'R'; break; 3127 case OP_FTRWRITE: opchar = 'W'; break; 3128 case OP_FTREXEC: opchar = 'X'; break; 3129 case OP_FTEREAD: opchar = 'r'; break; 3130 case OP_FTEWRITE: opchar = 'w'; break; 3131 case OP_FTEEXEC: opchar = 'x'; break; 3132 } 3133 tryAMAGICftest_MG(opchar); 3134 3135 switch (PL_op->op_type) { 3136 case OP_FTRREAD: 3137 #if !(defined(HAS_ACCESS) && defined(R_OK)) 3138 use_access = 0; 3139 #endif 3140 break; 3141 3142 case OP_FTRWRITE: 3143 #if defined(HAS_ACCESS) && defined(W_OK) 3144 access_mode = W_OK; 3145 #else 3146 use_access = 0; 3147 #endif 3148 stat_mode = S_IWUSR; 3149 break; 3150 3151 case OP_FTREXEC: 3152 #if defined(HAS_ACCESS) && defined(X_OK) 3153 access_mode = X_OK; 3154 #else 3155 use_access = 0; 3156 #endif 3157 stat_mode = S_IXUSR; 3158 break; 3159 3160 case OP_FTEWRITE: 3161 #ifdef PERL_EFF_ACCESS 3162 access_mode = W_OK; 3163 #endif 3164 stat_mode = S_IWUSR; 3165 /* FALLTHROUGH */ 3166 3167 case OP_FTEREAD: 3168 #ifndef PERL_EFF_ACCESS 3169 use_access = 0; 3170 #endif 3171 effective = TRUE; 3172 break; 3173 3174 case OP_FTEEXEC: 3175 #ifdef PERL_EFF_ACCESS 3176 access_mode = X_OK; 3177 #else 3178 use_access = 0; 3179 #endif 3180 stat_mode = S_IXUSR; 3181 effective = TRUE; 3182 break; 3183 } 3184 3185 if (use_access) { 3186 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) 3187 STRLEN len; 3188 const char *name = SvPV(*PL_stack_sp, len); 3189 if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) { 3190 result = -1; 3191 } 3192 else if (effective) { 3193 # ifdef PERL_EFF_ACCESS 3194 result = PERL_EFF_ACCESS(name, access_mode); 3195 # else 3196 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s", 3197 OP_NAME(PL_op)); 3198 # endif 3199 } 3200 else { 3201 # ifdef HAS_ACCESS 3202 result = access(name, access_mode); 3203 # else 3204 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op)); 3205 # endif 3206 } 3207 if (result == 0) 3208 FT_RETURNYES; 3209 if (result < 0) 3210 FT_RETURNUNDEF; 3211 FT_RETURNNO; 3212 #endif 3213 } 3214 3215 result = my_stat_flags(0); 3216 if (result < 0) 3217 FT_RETURNUNDEF; 3218 if (cando(stat_mode, effective, &PL_statcache)) 3219 FT_RETURNYES; 3220 FT_RETURNNO; 3221 } 3222 3223 3224 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */ 3225 3226 PP(pp_ftis) 3227 { 3228 I32 result; 3229 const int op_type = PL_op->op_type; 3230 char opchar = '?'; 3231 3232 switch (op_type) { 3233 case OP_FTIS: opchar = 'e'; break; 3234 case OP_FTSIZE: opchar = 's'; break; 3235 case OP_FTMTIME: opchar = 'M'; break; 3236 case OP_FTCTIME: opchar = 'C'; break; 3237 case OP_FTATIME: opchar = 'A'; break; 3238 } 3239 tryAMAGICftest_MG(opchar); 3240 3241 result = my_stat_flags(0); 3242 if (result < 0) 3243 FT_RETURNUNDEF; 3244 if (op_type == OP_FTIS) 3245 FT_RETURNYES; 3246 { 3247 /* You can't dTARGET inside OP_FTIS, because you'll get 3248 "panic: pad_sv po" - the op is not flagged to have a target. */ 3249 dTARGET; 3250 switch (op_type) { 3251 case OP_FTSIZE: 3252 #if Off_t_size > IVSIZE 3253 sv_setnv(TARG, (NV)PL_statcache.st_size); 3254 #else 3255 sv_setiv(TARG, (IV)PL_statcache.st_size); 3256 #endif 3257 break; 3258 case OP_FTMTIME: 3259 sv_setnv(TARG, 3260 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 ); 3261 break; 3262 case OP_FTATIME: 3263 sv_setnv(TARG, 3264 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 ); 3265 break; 3266 case OP_FTCTIME: 3267 sv_setnv(TARG, 3268 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 ); 3269 break; 3270 } 3271 SvSETMAGIC(TARG); 3272 return SvTRUE_nomg_NN(TARG) 3273 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG); 3274 } 3275 } 3276 3277 3278 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned() 3279 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock() 3280 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */ 3281 3282 PP(pp_ftrowned) 3283 { 3284 I32 result; 3285 char opchar = '?'; 3286 3287 switch (PL_op->op_type) { 3288 case OP_FTROWNED: opchar = 'O'; break; 3289 case OP_FTEOWNED: opchar = 'o'; break; 3290 case OP_FTZERO: opchar = 'z'; break; 3291 case OP_FTSOCK: opchar = 'S'; break; 3292 case OP_FTCHR: opchar = 'c'; break; 3293 case OP_FTBLK: opchar = 'b'; break; 3294 case OP_FTFILE: opchar = 'f'; break; 3295 case OP_FTDIR: opchar = 'd'; break; 3296 case OP_FTPIPE: opchar = 'p'; break; 3297 case OP_FTSUID: opchar = 'u'; break; 3298 case OP_FTSGID: opchar = 'g'; break; 3299 case OP_FTSVTX: opchar = 'k'; break; 3300 } 3301 tryAMAGICftest_MG(opchar); 3302 3303 result = my_stat_flags(0); 3304 if (result < 0) 3305 FT_RETURNUNDEF; 3306 switch (PL_op->op_type) { 3307 case OP_FTROWNED: 3308 if (PL_statcache.st_uid == PerlProc_getuid()) 3309 FT_RETURNYES; 3310 break; 3311 case OP_FTEOWNED: 3312 if (PL_statcache.st_uid == PerlProc_geteuid()) 3313 FT_RETURNYES; 3314 break; 3315 case OP_FTZERO: 3316 if (PL_statcache.st_size == 0) 3317 FT_RETURNYES; 3318 break; 3319 case OP_FTSOCK: 3320 if (S_ISSOCK(PL_statcache.st_mode)) 3321 FT_RETURNYES; 3322 break; 3323 case OP_FTCHR: 3324 if (S_ISCHR(PL_statcache.st_mode)) 3325 FT_RETURNYES; 3326 break; 3327 case OP_FTBLK: 3328 if (S_ISBLK(PL_statcache.st_mode)) 3329 FT_RETURNYES; 3330 break; 3331 case OP_FTFILE: 3332 if (S_ISREG(PL_statcache.st_mode)) 3333 FT_RETURNYES; 3334 break; 3335 case OP_FTDIR: 3336 if (S_ISDIR(PL_statcache.st_mode)) 3337 FT_RETURNYES; 3338 break; 3339 case OP_FTPIPE: 3340 if (S_ISFIFO(PL_statcache.st_mode)) 3341 FT_RETURNYES; 3342 break; 3343 #ifdef S_ISUID 3344 case OP_FTSUID: 3345 if (PL_statcache.st_mode & S_ISUID) 3346 FT_RETURNYES; 3347 break; 3348 #endif 3349 #ifdef S_ISGID 3350 case OP_FTSGID: 3351 if (PL_statcache.st_mode & S_ISGID) 3352 FT_RETURNYES; 3353 break; 3354 #endif 3355 #ifdef S_ISVTX 3356 case OP_FTSVTX: 3357 if (PL_statcache.st_mode & S_ISVTX) 3358 FT_RETURNYES; 3359 break; 3360 #endif 3361 } 3362 FT_RETURNNO; 3363 } 3364 3365 PP(pp_ftlink) 3366 { 3367 I32 result; 3368 3369 tryAMAGICftest_MG('l'); 3370 result = my_lstat_flags(0); 3371 3372 if (result < 0) 3373 FT_RETURNUNDEF; 3374 if (S_ISLNK(PL_statcache.st_mode)) 3375 FT_RETURNYES; 3376 FT_RETURNNO; 3377 } 3378 3379 PP(pp_fttty) 3380 { 3381 int fd; 3382 GV *gv; 3383 char *name = NULL; 3384 STRLEN namelen; 3385 UV uv; 3386 3387 tryAMAGICftest_MG('t'); 3388 3389 if (PL_op->op_flags & OPf_REF) 3390 gv = cGVOP_gv; 3391 else { 3392 SV *tmpsv = *PL_stack_sp; 3393 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) { 3394 name = SvPV_nomg(tmpsv, namelen); 3395 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); 3396 } 3397 } 3398 3399 if (GvIO(gv) && IoIFP(GvIOp(gv))) 3400 fd = PerlIO_fileno(IoIFP(GvIOp(gv))); 3401 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX) 3402 fd = (int)uv; 3403 else 3404 fd = -1; 3405 if (fd < 0) { 3406 SETERRNO(EBADF,RMS_IFI); 3407 FT_RETURNUNDEF; 3408 } 3409 if (PerlLIO_isatty(fd)) 3410 FT_RETURNYES; 3411 FT_RETURNNO; 3412 } 3413 3414 3415 /* also used for: pp_ftbinary() */ 3416 3417 PP(pp_fttext) 3418 { 3419 I32 i; 3420 SSize_t len; 3421 I32 odd = 0; 3422 STDCHAR tbuf[512]; 3423 STDCHAR *s; 3424 IO *io; 3425 SV *sv = NULL; 3426 GV *gv; 3427 PerlIO *fp; 3428 const U8 * first_variant; 3429 3430 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); 3431 3432 if (PL_op->op_flags & OPf_REF) 3433 gv = cGVOP_gv; 3434 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 3435 == OPpFT_STACKED) 3436 gv = PL_defgv; 3437 else { 3438 sv = *PL_stack_sp; 3439 gv = MAYBE_DEREF_GV_nomg(sv); 3440 } 3441 3442 if (gv) { 3443 if (gv == PL_defgv) { 3444 if (PL_statgv) 3445 io = SvTYPE(PL_statgv) == SVt_PVIO 3446 ? (IO *)PL_statgv 3447 : GvIO(PL_statgv); 3448 else { 3449 goto really_filename; 3450 } 3451 } 3452 else { 3453 PL_statgv = gv; 3454 SvPVCLEAR(PL_statname); 3455 io = GvIO(PL_statgv); 3456 } 3457 PL_laststatval = -1; 3458 PL_laststype = OP_STAT; 3459 if (io && IoIFP(io)) { 3460 int fd; 3461 if (! PerlIO_has_base(IoIFP(io))) 3462 DIE(aTHX_ "-T and -B not implemented on filehandles"); 3463 fd = PerlIO_fileno(IoIFP(io)); 3464 if (fd < 0) { 3465 SETERRNO(EBADF,RMS_IFI); 3466 FT_RETURNUNDEF; 3467 } 3468 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); 3469 if (PL_laststatval < 0) 3470 FT_RETURNUNDEF; 3471 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ 3472 if (PL_op->op_type == OP_FTTEXT) 3473 FT_RETURNNO; 3474 else 3475 FT_RETURNYES; 3476 } 3477 if (PerlIO_get_cnt(IoIFP(io)) <= 0) { 3478 i = PerlIO_getc(IoIFP(io)); 3479 if (i != EOF) 3480 (void)PerlIO_ungetc(IoIFP(io),i); 3481 else 3482 /* null file is anything */ 3483 FT_RETURNYES; 3484 } 3485 len = PerlIO_get_bufsiz(IoIFP(io)); 3486 s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); 3487 /* sfio can have large buffers - limit to 512 */ 3488 if (len > 512) 3489 len = 512; 3490 } 3491 else { 3492 SETERRNO(EBADF,RMS_IFI); 3493 report_evil_fh(gv); 3494 SETERRNO(EBADF,RMS_IFI); 3495 FT_RETURNUNDEF; 3496 } 3497 } 3498 else { 3499 const char *file; 3500 const char *temp; 3501 STRLEN temp_len; 3502 int fd; 3503 3504 assert(sv); 3505 temp = SvPV_nomg_const(sv, temp_len); 3506 sv_setpv(PL_statname, temp); 3507 if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) { 3508 PL_laststatval = -1; 3509 PL_laststype = OP_STAT; 3510 FT_RETURNUNDEF; 3511 } 3512 really_filename: 3513 file = SvPVX_const(PL_statname); 3514 PL_statgv = NULL; 3515 if (!(fp = PerlIO_open(file, "r"))) { 3516 if (!gv) { 3517 PL_laststatval = -1; 3518 PL_laststype = OP_STAT; 3519 } 3520 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { 3521 /* PL_warn_nl is constant */ 3522 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); 3523 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); 3524 GCC_DIAG_RESTORE_STMT; 3525 } 3526 FT_RETURNUNDEF; 3527 } 3528 PL_laststype = OP_STAT; 3529 fd = PerlIO_fileno(fp); 3530 if (fd < 0) { 3531 (void)PerlIO_close(fp); 3532 SETERRNO(EBADF,RMS_IFI); 3533 FT_RETURNUNDEF; 3534 } 3535 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); 3536 if (PL_laststatval < 0) { 3537 dSAVE_ERRNO; 3538 (void)PerlIO_close(fp); 3539 RESTORE_ERRNO; 3540 FT_RETURNUNDEF; 3541 } 3542 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); 3543 len = PerlIO_read(fp, tbuf, sizeof(tbuf)); 3544 (void)PerlIO_close(fp); 3545 if (len <= 0) { 3546 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) 3547 FT_RETURNNO; /* special case NFS directories */ 3548 FT_RETURNYES; /* null file is anything */ 3549 } 3550 s = tbuf; 3551 } 3552 3553 /* now scan s to look for textiness */ 3554 3555 #if defined(DOSISH) || defined(USEMYBINMODE) 3556 /* ignore trailing ^Z on short files */ 3557 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26) 3558 --len; 3559 #endif 3560 3561 assert(len); 3562 if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) { 3563 3564 /* Here contains a variant under UTF-8 . See if the entire string is 3565 * UTF-8. */ 3566 if (is_utf8_fixed_width_buf_flags(first_variant, 3567 len - ((char *) first_variant - (char *) s), 3568 0)) 3569 { 3570 if (PL_op->op_type == OP_FTTEXT) { 3571 FT_RETURNYES; 3572 } 3573 else { 3574 FT_RETURNNO; 3575 } 3576 } 3577 } 3578 3579 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for 3580 * things that wouldn't be in ASCII text or rich ASCII text. Count these 3581 * in 'odd' */ 3582 for (i = 0; i < len; i++, s++) { 3583 if (!*s) { /* null never allowed in text */ 3584 odd += len; 3585 break; 3586 } 3587 #ifdef USE_LOCALE_CTYPE 3588 if (IN_LC_RUNTIME(LC_CTYPE)) { 3589 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) { 3590 continue; 3591 } 3592 } 3593 else 3594 #endif 3595 if ( isPRINT_A(*s) 3596 /* VT occurs so rarely in text, that we consider it odd */ 3597 || (isSPACE_A(*s) && *s != VT_NATIVE) 3598 3599 /* But there is a fair amount of backspaces and escapes in 3600 * some text */ 3601 || *s == '\b' 3602 || *s == ESC_NATIVE) 3603 { 3604 continue; 3605 } 3606 odd++; 3607 } 3608 3609 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ 3610 FT_RETURNNO; 3611 else 3612 FT_RETURNYES; 3613 } 3614 3615 /* File calls. */ 3616 3617 PP(pp_chdir) 3618 { 3619 dSP; dTARGET; 3620 const char *tmps = NULL; 3621 GV *gv = NULL; 3622 3623 if( MAXARG == 1 ) { 3624 SV * const sv = POPs; 3625 if (PL_op->op_flags & OPf_SPECIAL) { 3626 gv = gv_fetchsv(sv, 0, SVt_PVIO); 3627 if (!gv) { 3628 if (ckWARN(WARN_UNOPENED)) { 3629 Perl_warner(aTHX_ packWARN(WARN_UNOPENED), 3630 "chdir() on unopened filehandle %" SVf, sv); 3631 } 3632 SETERRNO(EBADF,RMS_IFI); 3633 PUSHs(&PL_sv_zero); 3634 TAINT_PROPER("chdir"); 3635 RETURN; 3636 } 3637 } 3638 else if (!(gv = MAYBE_DEREF_GV(sv))) 3639 tmps = SvPV_nomg_const_nolen(sv); 3640 } 3641 else { 3642 HV * const table = GvHVn(PL_envgv); 3643 SV **svp; 3644 3645 EXTEND(SP, 1); 3646 if ( (svp = hv_fetchs(table, "HOME", FALSE)) 3647 || (svp = hv_fetchs(table, "LOGDIR", FALSE)) 3648 #ifdef VMS 3649 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE)) 3650 #endif 3651 ) 3652 { 3653 tmps = SvPV_nolen_const(*svp); 3654 } 3655 else { 3656 PUSHs(&PL_sv_zero); 3657 SETERRNO(EINVAL, LIB_INVARG); 3658 TAINT_PROPER("chdir"); 3659 RETURN; 3660 } 3661 } 3662 3663 TAINT_PROPER("chdir"); 3664 if (gv) { 3665 #ifdef HAS_FCHDIR 3666 IO* const io = GvIO(gv); 3667 if (io) { 3668 if (IoDIRP(io)) { 3669 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); 3670 } else if (IoIFP(io)) { 3671 int fd = PerlIO_fileno(IoIFP(io)); 3672 if (fd < 0) { 3673 goto nuts; 3674 } 3675 PUSHi(fchdir(fd) >= 0); 3676 } 3677 else { 3678 goto nuts; 3679 } 3680 } else { 3681 goto nuts; 3682 } 3683 3684 #else 3685 DIE(aTHX_ PL_no_func, "fchdir"); 3686 #endif 3687 } 3688 else 3689 PUSHi( PerlDir_chdir(tmps) >= 0 ); 3690 #ifdef VMS 3691 /* Clear the DEFAULT element of ENV so we'll get the new value 3692 * in the future. */ 3693 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD); 3694 #endif 3695 RETURN; 3696 3697 #ifdef HAS_FCHDIR 3698 nuts: 3699 report_evil_fh(gv); 3700 SETERRNO(EBADF,RMS_IFI); 3701 PUSHs(&PL_sv_zero); 3702 RETURN; 3703 #endif 3704 } 3705 3706 3707 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */ 3708 3709 PP(pp_chown) 3710 { 3711 dSP; dMARK; dTARGET; 3712 const I32 value = (I32)apply(PL_op->op_type, MARK, SP); 3713 3714 SP = MARK; 3715 XPUSHi(value); 3716 RETURN; 3717 } 3718 3719 PP(pp_chroot) 3720 { 3721 #ifdef HAS_CHROOT 3722 dSP; dTARGET; 3723 char * const tmps = POPpx; 3724 TAINT_PROPER("chroot"); 3725 PUSHi( chroot(tmps) >= 0 ); 3726 RETURN; 3727 #else 3728 DIE(aTHX_ PL_no_func, "chroot"); 3729 #endif 3730 } 3731 3732 PP(pp_rename) 3733 { 3734 dSP; dTARGET; 3735 int anum; 3736 #ifndef HAS_RENAME 3737 Stat_t statbuf; 3738 #endif 3739 const char * const tmps2 = POPpconstx; 3740 const char * const tmps = SvPV_nolen_const(TOPs); 3741 TAINT_PROPER("rename"); 3742 #ifdef HAS_RENAME 3743 anum = PerlLIO_rename(tmps, tmps2); 3744 #else 3745 if (!(anum = PerlLIO_stat(tmps, &statbuf))) { 3746 if (same_dirent(tmps2, tmps)) /* can always rename to same name */ 3747 anum = 1; 3748 else { 3749 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) 3750 (void)UNLINK(tmps2); 3751 if (!(anum = link(tmps, tmps2))) 3752 anum = UNLINK(tmps); 3753 } 3754 } 3755 #endif 3756 SETi( anum >= 0 ); 3757 RETURN; 3758 } 3759 3760 3761 /* also used for: pp_symlink() */ 3762 3763 #if defined(HAS_LINK) || defined(HAS_SYMLINK) 3764 PP(pp_link) 3765 { 3766 dSP; dTARGET; 3767 const int op_type = PL_op->op_type; 3768 int result; 3769 3770 # ifndef HAS_LINK 3771 if (op_type == OP_LINK) 3772 DIE(aTHX_ PL_no_func, "link"); 3773 # endif 3774 # ifndef HAS_SYMLINK 3775 if (op_type == OP_SYMLINK) 3776 DIE(aTHX_ PL_no_func, "symlink"); 3777 # endif 3778 3779 { 3780 const char * const tmps2 = POPpconstx; 3781 const char * const tmps = SvPV_nolen_const(TOPs); 3782 TAINT_PROPER(PL_op_desc[op_type]); 3783 result = 3784 # if defined(HAS_LINK) && defined(HAS_SYMLINK) 3785 /* Both present - need to choose which. */ 3786 (op_type == OP_LINK) ? 3787 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2); 3788 # elif defined(HAS_LINK) 3789 /* Only have link, so calls to pp_symlink will have DIE()d above. */ 3790 PerlLIO_link(tmps, tmps2); 3791 # elif defined(HAS_SYMLINK) 3792 /* Only have symlink, so calls to pp_link will have DIE()d above. */ 3793 symlink(tmps, tmps2); 3794 # endif 3795 } 3796 3797 SETi( result >= 0 ); 3798 RETURN; 3799 } 3800 #else 3801 3802 /* also used for: pp_symlink() */ 3803 3804 PP(pp_link) 3805 { 3806 /* Have neither. */ 3807 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 3808 } 3809 #endif 3810 3811 PP(pp_readlink) 3812 { 3813 dSP; 3814 #ifdef HAS_SYMLINK 3815 dTARGET; 3816 const char *tmps; 3817 char buf[MAXPATHLEN]; 3818 SSize_t len; 3819 3820 TAINT; 3821 tmps = POPpconstx; 3822 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1, 3823 * it is impossible to know whether the result was truncated. */ 3824 len = readlink(tmps, buf, sizeof(buf) - 1); 3825 if (len < 0) 3826 RETPUSHUNDEF; 3827 buf[len] = '\0'; 3828 PUSHp(buf, len); 3829 RETURN; 3830 #else 3831 EXTEND(SP, 1); 3832 RETSETUNDEF; /* just pretend it's a normal file */ 3833 #endif 3834 } 3835 3836 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR) 3837 STATIC int 3838 S_dooneliner(pTHX_ const char *cmd, const char *filename) 3839 { 3840 char * const save_filename = filename; 3841 char *cmdline; 3842 char *s; 3843 PerlIO *myfp; 3844 int anum = 1; 3845 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10; 3846 3847 PERL_ARGS_ASSERT_DOONELINER; 3848 3849 Newx(cmdline, size, char); 3850 my_strlcpy(cmdline, cmd, size); 3851 my_strlcat(cmdline, " ", size); 3852 for (s = cmdline + strlen(cmdline); *filename; ) { 3853 *s++ = '\\'; 3854 *s++ = *filename++; 3855 } 3856 if (s - cmdline < size) 3857 my_strlcpy(s, " 2>&1", size - (s - cmdline)); 3858 myfp = PerlProc_popen(cmdline, "r"); 3859 Safefree(cmdline); 3860 3861 if (myfp) { 3862 SV * const tmpsv = sv_newmortal(); 3863 /* Need to save/restore 'PL_rs' ?? */ 3864 s = sv_gets(tmpsv, myfp, 0); 3865 (void)PerlProc_pclose(myfp); 3866 if (s != NULL) { 3867 int e; 3868 for (e = 1; 3869 #ifdef HAS_SYS_ERRLIST 3870 e <= sys_nerr 3871 #endif 3872 ; e++) 3873 { 3874 /* you don't see this */ 3875 const char * const errmsg = Strerror(e) ; 3876 if (!errmsg) 3877 break; 3878 if (instr(s, errmsg)) { 3879 SETERRNO(e,0); 3880 return 0; 3881 } 3882 } 3883 SETERRNO(0,0); 3884 #ifndef EACCES 3885 #define EACCES EPERM 3886 #endif 3887 if (instr(s, "cannot make")) 3888 SETERRNO(EEXIST,RMS_FEX); 3889 else if (instr(s, "existing file")) 3890 SETERRNO(EEXIST,RMS_FEX); 3891 else if (instr(s, "ile exists")) 3892 SETERRNO(EEXIST,RMS_FEX); 3893 else if (instr(s, "non-exist")) 3894 SETERRNO(ENOENT,RMS_FNF); 3895 else if (instr(s, "does not exist")) 3896 SETERRNO(ENOENT,RMS_FNF); 3897 else if (instr(s, "not empty")) 3898 SETERRNO(EBUSY,SS_DEVOFFLINE); 3899 else if (instr(s, "cannot access")) 3900 SETERRNO(EACCES,RMS_PRV); 3901 else 3902 SETERRNO(EPERM,RMS_PRV); 3903 return 0; 3904 } 3905 else { /* some mkdirs return no failure indication */ 3906 Stat_t statbuf; 3907 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0); 3908 if (PL_op->op_type == OP_RMDIR) 3909 anum = !anum; 3910 if (anum) 3911 SETERRNO(0,0); 3912 else 3913 SETERRNO(EACCES,RMS_PRV); /* a guess */ 3914 } 3915 return anum; 3916 } 3917 else 3918 return 0; 3919 } 3920 #endif 3921 3922 /* This macro removes trailing slashes from a directory name. 3923 * Different operating and file systems take differently to 3924 * trailing slashes. According to POSIX 1003.1 1996 Edition 3925 * any number of trailing slashes should be allowed. 3926 * Thusly we snip them away so that even non-conforming 3927 * systems are happy. 3928 * We should probably do this "filtering" for all 3929 * the functions that expect (potentially) directory names: 3930 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?, 3931 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */ 3932 3933 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \ 3934 if ((len) > 1 && (tmps)[(len)-1] == '/') { \ 3935 do { \ 3936 (len)--; \ 3937 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \ 3938 (tmps) = savepvn((tmps), (len)); \ 3939 (copy) = TRUE; \ 3940 } 3941 3942 PP(pp_mkdir) 3943 { 3944 dSP; dTARGET; 3945 STRLEN len; 3946 const char *tmps; 3947 bool copy = FALSE; 3948 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777; 3949 3950 TRIMSLASHES(tmps,len,copy); 3951 3952 TAINT_PROPER("mkdir"); 3953 #ifdef HAS_MKDIR 3954 SETi( PerlDir_mkdir(tmps, mode) >= 0 ); 3955 #else 3956 { 3957 int oldumask; 3958 SETi( dooneliner("mkdir", tmps) ); 3959 oldumask = PerlLIO_umask(0); 3960 PerlLIO_umask(oldumask); 3961 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777); 3962 } 3963 #endif 3964 if (copy) 3965 Safefree(tmps); 3966 RETURN; 3967 } 3968 3969 PP(pp_rmdir) 3970 { 3971 dSP; dTARGET; 3972 STRLEN len; 3973 const char *tmps; 3974 bool copy = FALSE; 3975 3976 TRIMSLASHES(tmps,len,copy); 3977 TAINT_PROPER("rmdir"); 3978 #ifdef HAS_RMDIR 3979 SETi( PerlDir_rmdir(tmps) >= 0 ); 3980 #else 3981 SETi( dooneliner("rmdir", tmps) ); 3982 #endif 3983 if (copy) 3984 Safefree(tmps); 3985 RETURN; 3986 } 3987 3988 /* Directory calls. */ 3989 3990 PP(pp_open_dir) 3991 { 3992 #if defined(Direntry_t) && defined(HAS_READDIR) 3993 dSP; 3994 const char * const dirname = POPpconstx; 3995 GV * const gv = MUTABLE_GV(POPs); 3996 IO * const io = GvIOn(gv); 3997 3998 if ((IoIFP(io) || IoOFP(io))) 3999 Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle", 4000 HEKfARG(GvENAME_HEK(gv))); 4001 if (IoDIRP(io)) 4002 PerlDir_close(IoDIRP(io)); 4003 if (!(IoDIRP(io) = PerlDir_open(dirname))) 4004 goto nope; 4005 4006 RETPUSHYES; 4007 nope: 4008 if (!errno) 4009 SETERRNO(EBADF,RMS_DIR); 4010 RETPUSHUNDEF; 4011 #else 4012 DIE(aTHX_ PL_no_dir_func, "opendir"); 4013 #endif 4014 } 4015 4016 PP(pp_readdir) 4017 { 4018 #if !defined(Direntry_t) || !defined(HAS_READDIR) 4019 DIE(aTHX_ PL_no_dir_func, "readdir"); 4020 #else 4021 #if !defined(I_DIRENT) && !defined(VMS) 4022 Direntry_t *readdir (DIR *); 4023 #endif 4024 dSP; 4025 4026 SV *sv; 4027 const U8 gimme = GIMME_V; 4028 GV * const gv = MUTABLE_GV(POPs); 4029 const Direntry_t *dp; 4030 IO * const io = GvIOn(gv); 4031 4032 if (!IoDIRP(io)) { 4033 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4034 "readdir() attempted on invalid dirhandle %" HEKf, 4035 HEKfARG(GvENAME_HEK(gv))); 4036 goto nope; 4037 } 4038 4039 do { 4040 dp = (Direntry_t *)PerlDir_read(IoDIRP(io)); 4041 if (!dp) 4042 break; 4043 #ifdef DIRNAMLEN 4044 sv = newSVpvn(dp->d_name, dp->d_namlen); 4045 #else 4046 sv = newSVpv(dp->d_name, 0); 4047 #endif 4048 if (!(IoFLAGS(io) & IOf_UNTAINT)) 4049 SvTAINTED_on(sv); 4050 mXPUSHs(sv); 4051 } while (gimme == G_ARRAY); 4052 4053 if (!dp && gimme != G_ARRAY) 4054 RETPUSHUNDEF; 4055 4056 RETURN; 4057 4058 nope: 4059 if (!errno) 4060 SETERRNO(EBADF,RMS_ISI); 4061 if (gimme == G_ARRAY) 4062 RETURN; 4063 else 4064 RETPUSHUNDEF; 4065 #endif 4066 } 4067 4068 PP(pp_telldir) 4069 { 4070 #if defined(HAS_TELLDIR) || defined(telldir) 4071 dSP; dTARGET; 4072 /* XXX does _anyone_ need this? --AD 2/20/1998 */ 4073 /* XXX netbsd still seemed to. 4074 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. 4075 --JHI 1999-Feb-02 */ 4076 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO) 4077 long telldir (DIR *); 4078 # endif 4079 GV * const gv = MUTABLE_GV(POPs); 4080 IO * const io = GvIOn(gv); 4081 4082 if (!IoDIRP(io)) { 4083 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4084 "telldir() attempted on invalid dirhandle %" HEKf, 4085 HEKfARG(GvENAME_HEK(gv))); 4086 goto nope; 4087 } 4088 4089 PUSHi( PerlDir_tell(IoDIRP(io)) ); 4090 RETURN; 4091 nope: 4092 if (!errno) 4093 SETERRNO(EBADF,RMS_ISI); 4094 RETPUSHUNDEF; 4095 #else 4096 DIE(aTHX_ PL_no_dir_func, "telldir"); 4097 #endif 4098 } 4099 4100 PP(pp_seekdir) 4101 { 4102 #if defined(HAS_SEEKDIR) || defined(seekdir) 4103 dSP; 4104 const long along = POPl; 4105 GV * const gv = MUTABLE_GV(POPs); 4106 IO * const io = GvIOn(gv); 4107 4108 if (!IoDIRP(io)) { 4109 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4110 "seekdir() attempted on invalid dirhandle %" HEKf, 4111 HEKfARG(GvENAME_HEK(gv))); 4112 goto nope; 4113 } 4114 (void)PerlDir_seek(IoDIRP(io), along); 4115 4116 RETPUSHYES; 4117 nope: 4118 if (!errno) 4119 SETERRNO(EBADF,RMS_ISI); 4120 RETPUSHUNDEF; 4121 #else 4122 DIE(aTHX_ PL_no_dir_func, "seekdir"); 4123 #endif 4124 } 4125 4126 PP(pp_rewinddir) 4127 { 4128 #if defined(HAS_REWINDDIR) || defined(rewinddir) 4129 dSP; 4130 GV * const gv = MUTABLE_GV(POPs); 4131 IO * const io = GvIOn(gv); 4132 4133 if (!IoDIRP(io)) { 4134 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4135 "rewinddir() attempted on invalid dirhandle %" HEKf, 4136 HEKfARG(GvENAME_HEK(gv))); 4137 goto nope; 4138 } 4139 (void)PerlDir_rewind(IoDIRP(io)); 4140 RETPUSHYES; 4141 nope: 4142 if (!errno) 4143 SETERRNO(EBADF,RMS_ISI); 4144 RETPUSHUNDEF; 4145 #else 4146 DIE(aTHX_ PL_no_dir_func, "rewinddir"); 4147 #endif 4148 } 4149 4150 PP(pp_closedir) 4151 { 4152 #if defined(Direntry_t) && defined(HAS_READDIR) 4153 dSP; 4154 GV * const gv = MUTABLE_GV(POPs); 4155 IO * const io = GvIOn(gv); 4156 4157 if (!IoDIRP(io)) { 4158 Perl_ck_warner(aTHX_ packWARN(WARN_IO), 4159 "closedir() attempted on invalid dirhandle %" HEKf, 4160 HEKfARG(GvENAME_HEK(gv))); 4161 goto nope; 4162 } 4163 #ifdef VOID_CLOSEDIR 4164 PerlDir_close(IoDIRP(io)); 4165 #else 4166 if (PerlDir_close(IoDIRP(io)) < 0) { 4167 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */ 4168 goto nope; 4169 } 4170 #endif 4171 IoDIRP(io) = 0; 4172 4173 RETPUSHYES; 4174 nope: 4175 if (!errno) 4176 SETERRNO(EBADF,RMS_IFI); 4177 RETPUSHUNDEF; 4178 #else 4179 DIE(aTHX_ PL_no_dir_func, "closedir"); 4180 #endif 4181 } 4182 4183 /* Process control. */ 4184 4185 PP(pp_fork) 4186 { 4187 #ifdef HAS_FORK 4188 dSP; dTARGET; 4189 Pid_t childpid; 4190 #ifdef HAS_SIGPROCMASK 4191 sigset_t oldmask, newmask; 4192 #endif 4193 4194 EXTEND(SP, 1); 4195 PERL_FLUSHALL_FOR_CHILD; 4196 #ifdef HAS_SIGPROCMASK 4197 sigfillset(&newmask); 4198 sigprocmask(SIG_SETMASK, &newmask, &oldmask); 4199 #endif 4200 childpid = PerlProc_fork(); 4201 if (childpid == 0) { 4202 int sig; 4203 PL_sig_pending = 0; 4204 if (PL_psig_pend) 4205 for (sig = 1; sig < SIG_SIZE; sig++) 4206 PL_psig_pend[sig] = 0; 4207 } 4208 #ifdef HAS_SIGPROCMASK 4209 { 4210 dSAVE_ERRNO; 4211 sigprocmask(SIG_SETMASK, &oldmask, NULL); 4212 RESTORE_ERRNO; 4213 } 4214 #endif 4215 if (childpid < 0) 4216 RETPUSHUNDEF; 4217 if (!childpid) { 4218 #ifdef PERL_USES_PL_PIDSTATUS 4219 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ 4220 #endif 4221 } 4222 PUSHi(childpid); 4223 RETURN; 4224 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__) 4225 dSP; dTARGET; 4226 Pid_t childpid; 4227 4228 EXTEND(SP, 1); 4229 PERL_FLUSHALL_FOR_CHILD; 4230 childpid = PerlProc_fork(); 4231 if (childpid == -1) 4232 RETPUSHUNDEF; 4233 PUSHi(childpid); 4234 RETURN; 4235 #else 4236 DIE(aTHX_ PL_no_func, "fork"); 4237 #endif 4238 } 4239 4240 PP(pp_wait) 4241 { 4242 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) 4243 dSP; dTARGET; 4244 Pid_t childpid; 4245 int argflags; 4246 4247 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 4248 childpid = wait4pid(-1, &argflags, 0); 4249 else { 4250 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && 4251 errno == EINTR) { 4252 PERL_ASYNC_CHECK(); 4253 } 4254 } 4255 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 4256 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ 4257 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1); 4258 # else 4259 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1); 4260 # endif 4261 XPUSHi(childpid); 4262 RETURN; 4263 #else 4264 DIE(aTHX_ PL_no_func, "wait"); 4265 #endif 4266 } 4267 4268 PP(pp_waitpid) 4269 { 4270 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) 4271 dSP; dTARGET; 4272 const int optype = POPi; 4273 const Pid_t pid = TOPi; 4274 Pid_t result; 4275 #ifdef __amigaos4__ 4276 int argflags = 0; 4277 result = amigaos_waitpid(aTHX_ optype, pid, &argflags); 4278 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1); 4279 result = result == 0 ? pid : -1; 4280 #else 4281 int argflags; 4282 4283 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 4284 result = wait4pid(pid, &argflags, optype); 4285 else { 4286 while ((result = wait4pid(pid, &argflags, optype)) == -1 && 4287 errno == EINTR) { 4288 PERL_ASYNC_CHECK(); 4289 } 4290 } 4291 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) 4292 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ 4293 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1); 4294 # else 4295 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); 4296 # endif 4297 # endif /* __amigaos4__ */ 4298 SETi(result); 4299 RETURN; 4300 #else 4301 DIE(aTHX_ PL_no_func, "waitpid"); 4302 #endif 4303 } 4304 4305 PP(pp_system) 4306 { 4307 dSP; dMARK; dORIGMARK; dTARGET; 4308 #if defined(__LIBCATAMOUNT__) 4309 PL_statusvalue = -1; 4310 SP = ORIGMARK; 4311 XPUSHi(-1); 4312 #else 4313 I32 value; 4314 # ifdef __amigaos4__ 4315 void * result; 4316 # else 4317 int result; 4318 # endif 4319 4320 while (++MARK <= SP) { 4321 SV *origsv = *MARK, *copysv; 4322 STRLEN len; 4323 char *pv; 4324 SvGETMAGIC(origsv); 4325 #if defined(WIN32) || defined(__VMS) 4326 /* 4327 * Because of a nasty platform-specific variation on the meaning 4328 * of arguments to this op, we must preserve numeric arguments 4329 * as numeric, not just retain the string value. 4330 */ 4331 if (SvNIOK(origsv) || SvNIOKp(origsv)) { 4332 copysv = newSV_type(SVt_PVNV); 4333 sv_2mortal(copysv); 4334 if (SvPOK(origsv) || SvPOKp(origsv)) { 4335 pv = SvPV_nomg(origsv, len); 4336 sv_setpvn(copysv, pv, len); 4337 SvPOK_off(copysv); 4338 } 4339 if (SvIOK(origsv) || SvIOKp(origsv)) 4340 SvIV_set(copysv, SvIVX(origsv)); 4341 if (SvNOK(origsv) || SvNOKp(origsv)) 4342 SvNV_set(copysv, SvNVX(origsv)); 4343 SvFLAGS(copysv) |= SvFLAGS(origsv) & 4344 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK| 4345 SVf_UTF8|SVf_IVisUV); 4346 } else 4347 #endif 4348 { 4349 pv = SvPV_nomg(origsv, len); 4350 copysv = newSVpvn_flags(pv, len, 4351 (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP); 4352 } 4353 *MARK = copysv; 4354 } 4355 MARK = ORIGMARK; 4356 4357 if (TAINTING_get) { 4358 TAINT_ENV(); 4359 TAINT_PROPER("system"); 4360 } 4361 PERL_FLUSHALL_FOR_CHILD; 4362 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) 4363 { 4364 #ifdef __amigaos4__ 4365 struct UserData userdata; 4366 pthread_t proc; 4367 #else 4368 Pid_t childpid; 4369 #endif 4370 int pp[2]; 4371 I32 did_pipes = 0; 4372 bool child_success = FALSE; 4373 #ifdef HAS_SIGPROCMASK 4374 sigset_t newset, oldset; 4375 #endif 4376 4377 if (PerlProc_pipe_cloexec(pp) >= 0) 4378 did_pipes = 1; 4379 #ifdef __amigaos4__ 4380 amigaos_fork_set_userdata(aTHX_ 4381 &userdata, 4382 did_pipes, 4383 pp[1], 4384 SP, 4385 mark); 4386 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata); 4387 child_success = proc > 0; 4388 #else 4389 #ifdef HAS_SIGPROCMASK 4390 sigemptyset(&newset); 4391 sigaddset(&newset, SIGCHLD); 4392 sigprocmask(SIG_BLOCK, &newset, &oldset); 4393 #endif 4394 while ((childpid = PerlProc_fork()) == -1) { 4395 if (errno != EAGAIN) { 4396 value = -1; 4397 SP = ORIGMARK; 4398 XPUSHi(value); 4399 if (did_pipes) { 4400 PerlLIO_close(pp[0]); 4401 PerlLIO_close(pp[1]); 4402 } 4403 #ifdef HAS_SIGPROCMASK 4404 sigprocmask(SIG_SETMASK, &oldset, NULL); 4405 #endif 4406 RETURN; 4407 } 4408 sleep(5); 4409 } 4410 child_success = childpid > 0; 4411 #endif 4412 if (child_success) { 4413 Sigsave_t ihand,qhand; /* place to save signals during system() */ 4414 int status; 4415 4416 #ifndef __amigaos4__ 4417 if (did_pipes) 4418 PerlLIO_close(pp[1]); 4419 #endif 4420 #ifndef PERL_MICRO 4421 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); 4422 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); 4423 #endif 4424 #ifdef __amigaos4__ 4425 result = pthread_join(proc, (void **)&status); 4426 #else 4427 do { 4428 result = wait4pid(childpid, &status, 0); 4429 } while (result == -1 && errno == EINTR); 4430 #endif 4431 #ifndef PERL_MICRO 4432 #ifdef HAS_SIGPROCMASK 4433 sigprocmask(SIG_SETMASK, &oldset, NULL); 4434 #endif 4435 (void)rsignal_restore(SIGINT, &ihand); 4436 (void)rsignal_restore(SIGQUIT, &qhand); 4437 #endif 4438 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); 4439 SP = ORIGMARK; 4440 if (did_pipes) { 4441 int errkid; 4442 unsigned n = 0; 4443 4444 while (n < sizeof(int)) { 4445 const SSize_t n1 = PerlLIO_read(pp[0], 4446 (void*)(((char*)&errkid)+n), 4447 (sizeof(int)) - n); 4448 if (n1 <= 0) 4449 break; 4450 n += n1; 4451 } 4452 PerlLIO_close(pp[0]); 4453 if (n) { /* Error */ 4454 if (n != sizeof(int)) 4455 DIE(aTHX_ "panic: kid popen errno read, n=%u", n); 4456 errno = errkid; /* Propagate errno from kid */ 4457 #ifdef __amigaos4__ 4458 /* The pipe always has something in it 4459 * so n alone is not enough. */ 4460 if (errno > 0) 4461 #endif 4462 { 4463 STATUS_NATIVE_CHILD_SET(-1); 4464 } 4465 } 4466 } 4467 XPUSHi(STATUS_CURRENT); 4468 RETURN; 4469 } 4470 #ifndef __amigaos4__ 4471 #ifdef HAS_SIGPROCMASK 4472 sigprocmask(SIG_SETMASK, &oldset, NULL); 4473 #endif 4474 if (did_pipes) 4475 PerlLIO_close(pp[0]); 4476 if (PL_op->op_flags & OPf_STACKED) { 4477 SV * const really = *++MARK; 4478 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); 4479 } 4480 else if (SP - MARK != 1) 4481 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes); 4482 else { 4483 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); 4484 } 4485 #endif /* __amigaos4__ */ 4486 PerlProc__exit(-1); 4487 } 4488 #else /* ! FORK or VMS or OS/2 */ 4489 PL_statusvalue = 0; 4490 result = 0; 4491 if (PL_op->op_flags & OPf_STACKED) { 4492 SV * const really = *++MARK; 4493 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) 4494 value = (I32)do_aspawn(really, MARK, SP); 4495 # else 4496 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); 4497 # endif 4498 } 4499 else if (SP - MARK != 1) { 4500 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) 4501 value = (I32)do_aspawn(NULL, MARK, SP); 4502 # else 4503 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); 4504 # endif 4505 } 4506 else { 4507 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); 4508 } 4509 if (PL_statusvalue == -1) /* hint that value must be returned as is */ 4510 result = 1; 4511 STATUS_NATIVE_CHILD_SET(value); 4512 SP = ORIGMARK; 4513 XPUSHi(result ? value : STATUS_CURRENT); 4514 #endif /* !FORK or VMS or OS/2 */ 4515 #endif 4516 RETURN; 4517 } 4518 4519 PP(pp_exec) 4520 { 4521 dSP; dMARK; dORIGMARK; dTARGET; 4522 I32 value; 4523 4524 if (TAINTING_get) { 4525 TAINT_ENV(); 4526 while (++MARK <= SP) { 4527 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ 4528 if (TAINT_get) 4529 break; 4530 } 4531 MARK = ORIGMARK; 4532 TAINT_PROPER("exec"); 4533 } 4534 4535 PERL_FLUSHALL_FOR_CHILD; 4536 if (PL_op->op_flags & OPf_STACKED) { 4537 SV * const really = *++MARK; 4538 value = (I32)do_aexec(really, MARK, SP); 4539 } 4540 else if (SP - MARK != 1) 4541 #ifdef VMS 4542 value = (I32)vms_do_aexec(NULL, MARK, SP); 4543 #else 4544 value = (I32)do_aexec(NULL, MARK, SP); 4545 #endif 4546 else { 4547 #ifdef VMS 4548 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); 4549 #else 4550 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); 4551 #endif 4552 } 4553 SP = ORIGMARK; 4554 XPUSHi(value); 4555 RETURN; 4556 } 4557 4558 PP(pp_getppid) 4559 { 4560 #ifdef HAS_GETPPID 4561 dSP; dTARGET; 4562 XPUSHi( getppid() ); 4563 RETURN; 4564 #else 4565 DIE(aTHX_ PL_no_func, "getppid"); 4566 #endif 4567 } 4568 4569 PP(pp_getpgrp) 4570 { 4571 #ifdef HAS_GETPGRP 4572 dSP; dTARGET; 4573 Pid_t pgrp; 4574 const Pid_t pid = 4575 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); 4576 4577 #ifdef BSD_GETPGRP 4578 pgrp = (I32)BSD_GETPGRP(pid); 4579 #else 4580 if (pid != 0 && pid != PerlProc_getpid()) 4581 DIE(aTHX_ "POSIX getpgrp can't take an argument"); 4582 pgrp = getpgrp(); 4583 #endif 4584 XPUSHi(pgrp); 4585 RETURN; 4586 #else 4587 DIE(aTHX_ PL_no_func, "getpgrp"); 4588 #endif 4589 } 4590 4591 PP(pp_setpgrp) 4592 { 4593 #ifdef HAS_SETPGRP 4594 dSP; dTARGET; 4595 Pid_t pgrp; 4596 Pid_t pid; 4597 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; 4598 if (MAXARG > 0) pid = TOPs ? TOPi : 0; 4599 else { 4600 pid = 0; 4601 EXTEND(SP,1); 4602 SP++; 4603 } 4604 4605 TAINT_PROPER("setpgrp"); 4606 #ifdef BSD_SETPGRP 4607 SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); 4608 #else 4609 if ((pgrp != 0 && pgrp != PerlProc_getpid()) 4610 || (pid != 0 && pid != PerlProc_getpid())) 4611 { 4612 DIE(aTHX_ "setpgrp can't take arguments"); 4613 } 4614 SETi( setpgrp() >= 0 ); 4615 #endif /* USE_BSDPGRP */ 4616 RETURN; 4617 #else 4618 DIE(aTHX_ PL_no_func, "setpgrp"); 4619 #endif 4620 } 4621 4622 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2)) 4623 # define PRIORITY_WHICH_T(which) (__priority_which_t)which 4624 #else 4625 # define PRIORITY_WHICH_T(which) which 4626 #endif 4627 4628 PP(pp_getpriority) 4629 { 4630 #ifdef HAS_GETPRIORITY 4631 dSP; dTARGET; 4632 const int who = POPi; 4633 const int which = TOPi; 4634 SETi( getpriority(PRIORITY_WHICH_T(which), who) ); 4635 RETURN; 4636 #else 4637 DIE(aTHX_ PL_no_func, "getpriority"); 4638 #endif 4639 } 4640 4641 PP(pp_setpriority) 4642 { 4643 #ifdef HAS_SETPRIORITY 4644 dSP; dTARGET; 4645 const int niceval = POPi; 4646 const int who = POPi; 4647 const int which = TOPi; 4648 TAINT_PROPER("setpriority"); 4649 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); 4650 RETURN; 4651 #else 4652 DIE(aTHX_ PL_no_func, "setpriority"); 4653 #endif 4654 } 4655 4656 #undef PRIORITY_WHICH_T 4657 4658 /* Time calls. */ 4659 4660 PP(pp_time) 4661 { 4662 dSP; dTARGET; 4663 #ifdef BIG_TIME 4664 XPUSHn( time(NULL) ); 4665 #else 4666 XPUSHi( time(NULL) ); 4667 #endif 4668 RETURN; 4669 } 4670 4671 PP(pp_tms) 4672 { 4673 #ifdef HAS_TIMES 4674 dSP; 4675 struct tms timesbuf; 4676 4677 EXTEND(SP, 4); 4678 (void)PerlProc_times(×buf); 4679 4680 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick); 4681 if (GIMME_V == G_ARRAY) { 4682 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick); 4683 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick); 4684 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick); 4685 } 4686 RETURN; 4687 #elif defined(PERL_MICRO) 4688 dSP; 4689 mPUSHn(0.0); 4690 EXTEND(SP, 4); 4691 if (GIMME_V == G_ARRAY) { 4692 mPUSHn(0.0); 4693 mPUSHn(0.0); 4694 mPUSHn(0.0); 4695 } 4696 RETURN; 4697 #else 4698 DIE(aTHX_ "times not implemented"); 4699 #endif /* HAS_TIMES */ 4700 } 4701 4702 /* The 32 bit int year limits the times we can represent to these 4703 boundaries with a few days wiggle room to account for time zone 4704 offsets 4705 */ 4706 /* Sat Jan 3 00:00:00 -2147481748 */ 4707 #define TIME_LOWER_BOUND -67768100567755200.0 4708 /* Sun Dec 29 12:00:00 2147483647 */ 4709 #define TIME_UPPER_BOUND 67767976233316800.0 4710 4711 4712 /* also used for: pp_localtime() */ 4713 4714 PP(pp_gmtime) 4715 { 4716 dSP; 4717 Time64_T when; 4718 struct TM tmbuf; 4719 struct TM *err; 4720 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime"; 4721 static const char * const dayname[] = 4722 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; 4723 static const char * const monname[] = 4724 {"Jan", "Feb", "Mar", "Apr", "May", "Jun", 4725 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; 4726 4727 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) { 4728 time_t now; 4729 (void)time(&now); 4730 when = (Time64_T)now; 4731 } 4732 else { 4733 NV input = Perl_floor(POPn); 4734 const bool pl_isnan = Perl_isnan(input); 4735 when = (Time64_T)input; 4736 if (UNLIKELY(pl_isnan || when != input)) { 4737 /* diag_listed_as: gmtime(%f) too large */ 4738 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4739 "%s(%.0" NVff ") too large", opname, input); 4740 if (pl_isnan) { 4741 err = NULL; 4742 goto failed; 4743 } 4744 } 4745 } 4746 4747 if ( TIME_LOWER_BOUND > when ) { 4748 /* diag_listed_as: gmtime(%f) too small */ 4749 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4750 "%s(%.0" NVff ") too small", opname, when); 4751 err = NULL; 4752 } 4753 else if( when > TIME_UPPER_BOUND ) { 4754 /* diag_listed_as: gmtime(%f) too small */ 4755 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4756 "%s(%.0" NVff ") too large", opname, when); 4757 err = NULL; 4758 } 4759 else { 4760 if (PL_op->op_type == OP_LOCALTIME) 4761 err = Perl_localtime64_r(&when, &tmbuf); 4762 else 4763 err = Perl_gmtime64_r(&when, &tmbuf); 4764 } 4765 4766 if (err == NULL) { 4767 /* diag_listed_as: gmtime(%f) failed */ 4768 /* XXX %lld broken for quads */ 4769 failed: 4770 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 4771 "%s(%.0" NVff ") failed", opname, when); 4772 } 4773 4774 if (GIMME_V != G_ARRAY) { /* scalar context */ 4775 EXTEND(SP, 1); 4776 if (err == NULL) 4777 RETPUSHUNDEF; 4778 else { 4779 dTARGET; 4780 PUSHs(TARG); 4781 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf, 4782 dayname[tmbuf.tm_wday], 4783 monname[tmbuf.tm_mon], 4784 tmbuf.tm_mday, 4785 tmbuf.tm_hour, 4786 tmbuf.tm_min, 4787 tmbuf.tm_sec, 4788 (IV)tmbuf.tm_year + 1900); 4789 } 4790 } 4791 else { /* list context */ 4792 if ( err == NULL ) 4793 RETURN; 4794 4795 EXTEND(SP, 9); 4796 EXTEND_MORTAL(9); 4797 mPUSHi(tmbuf.tm_sec); 4798 mPUSHi(tmbuf.tm_min); 4799 mPUSHi(tmbuf.tm_hour); 4800 mPUSHi(tmbuf.tm_mday); 4801 mPUSHi(tmbuf.tm_mon); 4802 mPUSHn(tmbuf.tm_year); 4803 mPUSHi(tmbuf.tm_wday); 4804 mPUSHi(tmbuf.tm_yday); 4805 mPUSHi(tmbuf.tm_isdst); 4806 } 4807 RETURN; 4808 } 4809 4810 PP(pp_alarm) 4811 { 4812 #ifdef HAS_ALARM 4813 dSP; dTARGET; 4814 /* alarm() takes an unsigned int number of seconds, and return the 4815 * unsigned int number of seconds remaining in the previous alarm 4816 * (alarms don't stack). Therefore negative return values are not 4817 * possible. */ 4818 int anum = POPi; 4819 if (anum < 0) { 4820 /* Note that while the C library function alarm() as such has 4821 * no errors defined (or in other words, properly behaving client 4822 * code shouldn't expect any), alarm() being obsoleted by 4823 * setitimer() and often being implemented in terms of 4824 * setitimer(), can fail. */ 4825 /* diag_listed_as: %s() with negative argument */ 4826 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), 4827 "alarm() with negative argument"); 4828 SETERRNO(EINVAL, LIB_INVARG); 4829 RETPUSHUNDEF; 4830 } 4831 else { 4832 unsigned int retval = alarm(anum); 4833 if ((int)retval < 0) /* Strictly speaking "cannot happen". */ 4834 RETPUSHUNDEF; 4835 PUSHu(retval); 4836 RETURN; 4837 } 4838 #else 4839 DIE(aTHX_ PL_no_func, "alarm"); 4840 #endif 4841 } 4842 4843 PP(pp_sleep) 4844 { 4845 dSP; dTARGET; 4846 Time_t lasttime; 4847 Time_t when; 4848 4849 (void)time(&lasttime); 4850 if (MAXARG < 1 || (!TOPs && !POPs)) 4851 PerlProc_pause(); 4852 else { 4853 const I32 duration = POPi; 4854 if (duration < 0) { 4855 /* diag_listed_as: %s() with negative argument */ 4856 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), 4857 "sleep() with negative argument"); 4858 SETERRNO(EINVAL, LIB_INVARG); 4859 XPUSHs(&PL_sv_zero); 4860 RETURN; 4861 } else { 4862 PerlProc_sleep((unsigned int)duration); 4863 } 4864 } 4865 (void)time(&when); 4866 XPUSHi(when - lasttime); 4867 RETURN; 4868 } 4869 4870 /* Shared memory. */ 4871 /* Merged with some message passing. */ 4872 4873 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */ 4874 4875 PP(pp_shmwrite) 4876 { 4877 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 4878 dSP; dMARK; dTARGET; 4879 const int op_type = PL_op->op_type; 4880 I32 value; 4881 4882 switch (op_type) { 4883 case OP_MSGSND: 4884 value = (I32)(do_msgsnd(MARK, SP) >= 0); 4885 break; 4886 case OP_MSGRCV: 4887 value = (I32)(do_msgrcv(MARK, SP) >= 0); 4888 break; 4889 case OP_SEMOP: 4890 value = (I32)(do_semop(MARK, SP) >= 0); 4891 break; 4892 default: 4893 value = (I32)(do_shmio(op_type, MARK, SP) >= 0); 4894 break; 4895 } 4896 4897 SP = MARK; 4898 PUSHi(value); 4899 RETURN; 4900 #else 4901 return Perl_pp_semget(aTHX); 4902 #endif 4903 } 4904 4905 /* Semaphores. */ 4906 4907 /* also used for: pp_msgget() pp_shmget() */ 4908 4909 PP(pp_semget) 4910 { 4911 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 4912 dSP; dMARK; dTARGET; 4913 const int anum = do_ipcget(PL_op->op_type, MARK, SP); 4914 SP = MARK; 4915 if (anum == -1) 4916 RETPUSHUNDEF; 4917 PUSHi(anum); 4918 RETURN; 4919 #else 4920 DIE(aTHX_ "System V IPC is not implemented on this machine"); 4921 #endif 4922 } 4923 4924 /* also used for: pp_msgctl() pp_shmctl() */ 4925 4926 PP(pp_semctl) 4927 { 4928 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 4929 dSP; dMARK; dTARGET; 4930 const int anum = do_ipcctl(PL_op->op_type, MARK, SP); 4931 SP = MARK; 4932 if (anum == -1) 4933 RETPUSHUNDEF; 4934 if (anum != 0) { 4935 PUSHi(anum); 4936 } 4937 else { 4938 PUSHp(zero_but_true, ZBTLEN); 4939 } 4940 RETURN; 4941 #else 4942 return Perl_pp_semget(aTHX); 4943 #endif 4944 } 4945 4946 /* I can't const this further without getting warnings about the types of 4947 various arrays passed in from structures. */ 4948 static SV * 4949 S_space_join_names_mortal(pTHX_ char *const *array) 4950 { 4951 SV *target; 4952 4953 if (array && *array) { 4954 target = newSVpvs_flags("", SVs_TEMP); 4955 while (1) { 4956 sv_catpv(target, *array); 4957 if (!*++array) 4958 break; 4959 sv_catpvs(target, " "); 4960 } 4961 } else { 4962 target = sv_mortalcopy(&PL_sv_no); 4963 } 4964 return target; 4965 } 4966 4967 /* Get system info. */ 4968 4969 /* also used for: pp_ghbyaddr() pp_ghbyname() */ 4970 4971 PP(pp_ghostent) 4972 { 4973 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) 4974 dSP; 4975 I32 which = PL_op->op_type; 4976 char **elem; 4977 SV *sv; 4978 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ 4979 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); 4980 struct hostent *gethostbyname(Netdb_name_t); 4981 struct hostent *gethostent(void); 4982 #endif 4983 struct hostent *hent = NULL; 4984 unsigned long len; 4985 4986 EXTEND(SP, 10); 4987 if (which == OP_GHBYNAME) { 4988 #ifdef HAS_GETHOSTBYNAME 4989 const char* const name = POPpbytex; 4990 hent = PerlSock_gethostbyname(name); 4991 #else 4992 DIE(aTHX_ PL_no_sock_func, "gethostbyname"); 4993 #endif 4994 } 4995 else if (which == OP_GHBYADDR) { 4996 #ifdef HAS_GETHOSTBYADDR 4997 const int addrtype = POPi; 4998 SV * const addrsv = POPs; 4999 STRLEN addrlen; 5000 const char *addr = (char *)SvPVbyte(addrsv, addrlen); 5001 5002 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); 5003 #else 5004 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr"); 5005 #endif 5006 } 5007 else 5008 #ifdef HAS_GETHOSTENT 5009 hent = PerlSock_gethostent(); 5010 #else 5011 DIE(aTHX_ PL_no_sock_func, "gethostent"); 5012 #endif 5013 5014 #ifdef HOST_NOT_FOUND 5015 if (!hent) { 5016 #ifdef USE_REENTRANT_API 5017 # ifdef USE_GETHOSTENT_ERRNO 5018 h_errno = PL_reentrant_buffer->_gethostent_errno; 5019 # endif 5020 #endif 5021 STATUS_UNIX_SET(h_errno); 5022 } 5023 #endif 5024 5025 if (GIMME_V != G_ARRAY) { 5026 PUSHs(sv = sv_newmortal()); 5027 if (hent) { 5028 if (which == OP_GHBYNAME) { 5029 if (hent->h_addr) 5030 sv_setpvn(sv, hent->h_addr, hent->h_length); 5031 } 5032 else 5033 sv_setpv(sv, (char*)hent->h_name); 5034 } 5035 RETURN; 5036 } 5037 5038 if (hent) { 5039 mPUSHs(newSVpv((char*)hent->h_name, 0)); 5040 PUSHs(space_join_names_mortal(hent->h_aliases)); 5041 mPUSHi(hent->h_addrtype); 5042 len = hent->h_length; 5043 mPUSHi(len); 5044 #ifdef h_addr 5045 for (elem = hent->h_addr_list; elem && *elem; elem++) { 5046 mXPUSHp(*elem, len); 5047 } 5048 #else 5049 if (hent->h_addr) 5050 mPUSHp(hent->h_addr, len); 5051 else 5052 PUSHs(sv_mortalcopy(&PL_sv_no)); 5053 #endif /* h_addr */ 5054 } 5055 RETURN; 5056 #else 5057 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5058 #endif 5059 } 5060 5061 /* also used for: pp_gnbyaddr() pp_gnbyname() */ 5062 5063 PP(pp_gnetent) 5064 { 5065 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) 5066 dSP; 5067 I32 which = PL_op->op_type; 5068 SV *sv; 5069 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ 5070 struct netent *getnetbyaddr(Netdb_net_t, int); 5071 struct netent *getnetbyname(Netdb_name_t); 5072 struct netent *getnetent(void); 5073 #endif 5074 struct netent *nent; 5075 5076 if (which == OP_GNBYNAME){ 5077 #ifdef HAS_GETNETBYNAME 5078 const char * const name = POPpbytex; 5079 nent = PerlSock_getnetbyname(name); 5080 #else 5081 DIE(aTHX_ PL_no_sock_func, "getnetbyname"); 5082 #endif 5083 } 5084 else if (which == OP_GNBYADDR) { 5085 #ifdef HAS_GETNETBYADDR 5086 const int addrtype = POPi; 5087 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu; 5088 nent = PerlSock_getnetbyaddr(addr, addrtype); 5089 #else 5090 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); 5091 #endif 5092 } 5093 else 5094 #ifdef HAS_GETNETENT 5095 nent = PerlSock_getnetent(); 5096 #else 5097 DIE(aTHX_ PL_no_sock_func, "getnetent"); 5098 #endif 5099 5100 #ifdef HOST_NOT_FOUND 5101 if (!nent) { 5102 #ifdef USE_REENTRANT_API 5103 # ifdef USE_GETNETENT_ERRNO 5104 h_errno = PL_reentrant_buffer->_getnetent_errno; 5105 # endif 5106 #endif 5107 STATUS_UNIX_SET(h_errno); 5108 } 5109 #endif 5110 5111 EXTEND(SP, 4); 5112 if (GIMME_V != G_ARRAY) { 5113 PUSHs(sv = sv_newmortal()); 5114 if (nent) { 5115 if (which == OP_GNBYNAME) 5116 sv_setiv(sv, (IV)nent->n_net); 5117 else 5118 sv_setpv(sv, nent->n_name); 5119 } 5120 RETURN; 5121 } 5122 5123 if (nent) { 5124 mPUSHs(newSVpv(nent->n_name, 0)); 5125 PUSHs(space_join_names_mortal(nent->n_aliases)); 5126 mPUSHi(nent->n_addrtype); 5127 mPUSHi(nent->n_net); 5128 } 5129 5130 RETURN; 5131 #else 5132 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5133 #endif 5134 } 5135 5136 5137 /* also used for: pp_gpbyname() pp_gpbynumber() */ 5138 5139 PP(pp_gprotoent) 5140 { 5141 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) 5142 dSP; 5143 I32 which = PL_op->op_type; 5144 SV *sv; 5145 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ 5146 struct protoent *getprotobyname(Netdb_name_t); 5147 struct protoent *getprotobynumber(int); 5148 struct protoent *getprotoent(void); 5149 #endif 5150 struct protoent *pent; 5151 5152 if (which == OP_GPBYNAME) { 5153 #ifdef HAS_GETPROTOBYNAME 5154 const char* const name = POPpbytex; 5155 pent = PerlSock_getprotobyname(name); 5156 #else 5157 DIE(aTHX_ PL_no_sock_func, "getprotobyname"); 5158 #endif 5159 } 5160 else if (which == OP_GPBYNUMBER) { 5161 #ifdef HAS_GETPROTOBYNUMBER 5162 const int number = POPi; 5163 pent = PerlSock_getprotobynumber(number); 5164 #else 5165 DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); 5166 #endif 5167 } 5168 else 5169 #ifdef HAS_GETPROTOENT 5170 pent = PerlSock_getprotoent(); 5171 #else 5172 DIE(aTHX_ PL_no_sock_func, "getprotoent"); 5173 #endif 5174 5175 EXTEND(SP, 3); 5176 if (GIMME_V != G_ARRAY) { 5177 PUSHs(sv = sv_newmortal()); 5178 if (pent) { 5179 if (which == OP_GPBYNAME) 5180 sv_setiv(sv, (IV)pent->p_proto); 5181 else 5182 sv_setpv(sv, pent->p_name); 5183 } 5184 RETURN; 5185 } 5186 5187 if (pent) { 5188 mPUSHs(newSVpv(pent->p_name, 0)); 5189 PUSHs(space_join_names_mortal(pent->p_aliases)); 5190 mPUSHi(pent->p_proto); 5191 } 5192 5193 RETURN; 5194 #else 5195 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5196 #endif 5197 } 5198 5199 5200 /* also used for: pp_gsbyname() pp_gsbyport() */ 5201 5202 PP(pp_gservent) 5203 { 5204 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) 5205 dSP; 5206 I32 which = PL_op->op_type; 5207 SV *sv; 5208 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ 5209 struct servent *getservbyname(Netdb_name_t, Netdb_name_t); 5210 struct servent *getservbyport(int, Netdb_name_t); 5211 struct servent *getservent(void); 5212 #endif 5213 struct servent *sent; 5214 5215 if (which == OP_GSBYNAME) { 5216 #ifdef HAS_GETSERVBYNAME 5217 const char * const proto = POPpbytex; 5218 const char * const name = POPpbytex; 5219 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto); 5220 #else 5221 DIE(aTHX_ PL_no_sock_func, "getservbyname"); 5222 #endif 5223 } 5224 else if (which == OP_GSBYPORT) { 5225 #ifdef HAS_GETSERVBYPORT 5226 const char * const proto = POPpbytex; 5227 unsigned short port = (unsigned short)POPu; 5228 port = PerlSock_htons(port); 5229 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto); 5230 #else 5231 DIE(aTHX_ PL_no_sock_func, "getservbyport"); 5232 #endif 5233 } 5234 else 5235 #ifdef HAS_GETSERVENT 5236 sent = PerlSock_getservent(); 5237 #else 5238 DIE(aTHX_ PL_no_sock_func, "getservent"); 5239 #endif 5240 5241 EXTEND(SP, 4); 5242 if (GIMME_V != G_ARRAY) { 5243 PUSHs(sv = sv_newmortal()); 5244 if (sent) { 5245 if (which == OP_GSBYNAME) { 5246 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port)); 5247 } 5248 else 5249 sv_setpv(sv, sent->s_name); 5250 } 5251 RETURN; 5252 } 5253 5254 if (sent) { 5255 mPUSHs(newSVpv(sent->s_name, 0)); 5256 PUSHs(space_join_names_mortal(sent->s_aliases)); 5257 mPUSHi(PerlSock_ntohs(sent->s_port)); 5258 mPUSHs(newSVpv(sent->s_proto, 0)); 5259 } 5260 5261 RETURN; 5262 #else 5263 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5264 #endif 5265 } 5266 5267 5268 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */ 5269 5270 PP(pp_shostent) 5271 { 5272 dSP; 5273 const int stayopen = TOPi; 5274 switch(PL_op->op_type) { 5275 case OP_SHOSTENT: 5276 #ifdef HAS_SETHOSTENT 5277 PerlSock_sethostent(stayopen); 5278 #else 5279 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5280 #endif 5281 break; 5282 #ifdef HAS_SETNETENT 5283 case OP_SNETENT: 5284 PerlSock_setnetent(stayopen); 5285 #else 5286 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5287 #endif 5288 break; 5289 case OP_SPROTOENT: 5290 #ifdef HAS_SETPROTOENT 5291 PerlSock_setprotoent(stayopen); 5292 #else 5293 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5294 #endif 5295 break; 5296 case OP_SSERVENT: 5297 #ifdef HAS_SETSERVENT 5298 PerlSock_setservent(stayopen); 5299 #else 5300 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5301 #endif 5302 break; 5303 } 5304 RETSETYES; 5305 } 5306 5307 5308 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent() 5309 * pp_eservent() pp_sgrent() pp_spwent() */ 5310 5311 PP(pp_ehostent) 5312 { 5313 dSP; 5314 switch(PL_op->op_type) { 5315 case OP_EHOSTENT: 5316 #ifdef HAS_ENDHOSTENT 5317 PerlSock_endhostent(); 5318 #else 5319 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5320 #endif 5321 break; 5322 case OP_ENETENT: 5323 #ifdef HAS_ENDNETENT 5324 PerlSock_endnetent(); 5325 #else 5326 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5327 #endif 5328 break; 5329 case OP_EPROTOENT: 5330 #ifdef HAS_ENDPROTOENT 5331 PerlSock_endprotoent(); 5332 #else 5333 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5334 #endif 5335 break; 5336 case OP_ESERVENT: 5337 #ifdef HAS_ENDSERVENT 5338 PerlSock_endservent(); 5339 #else 5340 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); 5341 #endif 5342 break; 5343 case OP_SGRENT: 5344 #if defined(HAS_GROUP) && defined(HAS_SETGRENT) 5345 setgrent(); 5346 #else 5347 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5348 #endif 5349 break; 5350 case OP_EGRENT: 5351 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) 5352 endgrent(); 5353 #else 5354 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5355 #endif 5356 break; 5357 case OP_SPWENT: 5358 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) 5359 setpwent(); 5360 #else 5361 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5362 #endif 5363 break; 5364 case OP_EPWENT: 5365 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) 5366 endpwent(); 5367 #else 5368 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5369 #endif 5370 break; 5371 } 5372 EXTEND(SP,1); 5373 RETPUSHYES; 5374 } 5375 5376 5377 /* also used for: pp_gpwnam() pp_gpwuid() */ 5378 5379 PP(pp_gpwent) 5380 { 5381 #ifdef HAS_PASSWD 5382 dSP; 5383 I32 which = PL_op->op_type; 5384 SV *sv; 5385 struct passwd *pwent = NULL; 5386 /* 5387 * We currently support only the SysV getsp* shadow password interface. 5388 * The interface is declared in <shadow.h> and often one needs to link 5389 * with -lsecurity or some such. 5390 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux. 5391 * (and SCO?) 5392 * 5393 * AIX getpwnam() is clever enough to return the encrypted password 5394 * only if the caller (euid?) is root. 5395 * 5396 * There are at least three other shadow password APIs. Many platforms 5397 * seem to contain more than one interface for accessing the shadow 5398 * password databases, possibly for compatibility reasons. 5399 * The getsp*() is by far he simplest one, the other two interfaces 5400 * are much more complicated, but also very similar to each other. 5401 * 5402 * <sys/types.h> 5403 * <sys/security.h> 5404 * <prot.h> 5405 * struct pr_passwd *getprpw*(); 5406 * The password is in 5407 * char getprpw*(...).ufld.fd_encrypt[] 5408 * Mention HAS_GETPRPWNAM here so that Configure probes for it. 5409 * 5410 * <sys/types.h> 5411 * <sys/security.h> 5412 * <prot.h> 5413 * struct es_passwd *getespw*(); 5414 * The password is in 5415 * char *(getespw*(...).ufld.fd_encrypt) 5416 * Mention HAS_GETESPWNAM here so that Configure probes for it. 5417 * 5418 * <userpw.h> (AIX) 5419 * struct userpw *getuserpw(); 5420 * The password is in 5421 * char *(getuserpw(...)).spw_upw_passwd 5422 * (but the de facto standard getpwnam() should work okay) 5423 * 5424 * Mention I_PROT here so that Configure probes for it. 5425 * 5426 * In HP-UX for getprpw*() the manual page claims that one should include 5427 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed 5428 * if one includes <shadow.h> as that includes <hpsecurity.h>, 5429 * and pp_sys.c already includes <shadow.h> if there is such. 5430 * 5431 * Note that <sys/security.h> is already probed for, but currently 5432 * it is only included in special cases. 5433 * 5434 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be 5435 * be preferred interface, even though also the getprpw*() interface 5436 * is available) one needs to link with -lsecurity -ldb -laud -lm. 5437 * One also needs to call set_auth_parameters() in main() before 5438 * doing anything else, whether one is using getespw*() or getprpw*(). 5439 * 5440 * Note that accessing the shadow databases can be magnitudes 5441 * slower than accessing the standard databases. 5442 * 5443 * --jhi 5444 */ 5445 5446 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API) 5447 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r(): 5448 * the pw_comment is left uninitialized. */ 5449 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL; 5450 # endif 5451 5452 switch (which) { 5453 case OP_GPWNAM: 5454 { 5455 const char* const name = POPpbytex; 5456 pwent = getpwnam(name); 5457 } 5458 break; 5459 case OP_GPWUID: 5460 { 5461 Uid_t uid = POPi; 5462 pwent = getpwuid(uid); 5463 } 5464 break; 5465 case OP_GPWENT: 5466 # ifdef HAS_GETPWENT 5467 pwent = getpwent(); 5468 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ 5469 if (pwent) pwent = getpwnam(pwent->pw_name); 5470 #endif 5471 # else 5472 DIE(aTHX_ PL_no_func, "getpwent"); 5473 # endif 5474 break; 5475 } 5476 5477 EXTEND(SP, 10); 5478 if (GIMME_V != G_ARRAY) { 5479 PUSHs(sv = sv_newmortal()); 5480 if (pwent) { 5481 if (which == OP_GPWNAM) 5482 sv_setuid(sv, pwent->pw_uid); 5483 else 5484 sv_setpv(sv, pwent->pw_name); 5485 } 5486 RETURN; 5487 } 5488 5489 if (pwent) { 5490 mPUSHs(newSVpv(pwent->pw_name, 0)); 5491 5492 sv = newSViv(0); 5493 mPUSHs(sv); 5494 /* If we have getspnam(), we try to dig up the shadow 5495 * password. If we are underprivileged, the shadow 5496 * interface will set the errno to EACCES or similar, 5497 * and return a null pointer. If this happens, we will 5498 * use the dummy password (usually "*" or "x") from the 5499 * standard password database. 5500 * 5501 * In theory we could skip the shadow call completely 5502 * if euid != 0 but in practice we cannot know which 5503 * security measures are guarding the shadow databases 5504 * on a random platform. 5505 * 5506 * Resist the urge to use additional shadow interfaces. 5507 * Divert the urge to writing an extension instead. 5508 * 5509 * --jhi */ 5510 /* Some AIX setups falsely(?) detect some getspnam(), which 5511 * has a different API than the Solaris/IRIX one. */ 5512 # if defined(HAS_GETSPNAM) && !defined(_AIX) 5513 { 5514 dSAVE_ERRNO; 5515 const struct spwd * const spwent = getspnam(pwent->pw_name); 5516 /* Save and restore errno so that 5517 * underprivileged attempts seem 5518 * to have never made the unsuccessful 5519 * attempt to retrieve the shadow password. */ 5520 RESTORE_ERRNO; 5521 if (spwent && spwent->sp_pwdp) 5522 sv_setpv(sv, spwent->sp_pwdp); 5523 } 5524 # endif 5525 # ifdef PWPASSWD 5526 if (!SvPOK(sv)) /* Use the standard password, then. */ 5527 sv_setpv(sv, pwent->pw_passwd); 5528 # endif 5529 5530 /* passwd is tainted because user himself can diddle with it. 5531 * admittedly not much and in a very limited way, but nevertheless. */ 5532 SvTAINTED_on(sv); 5533 5534 sv_setuid(PUSHmortal, pwent->pw_uid); 5535 sv_setgid(PUSHmortal, pwent->pw_gid); 5536 5537 /* pw_change, pw_quota, and pw_age are mutually exclusive-- 5538 * because of the poor interface of the Perl getpw*(), 5539 * not because there's some standard/convention saying so. 5540 * A better interface would have been to return a hash, 5541 * but we are accursed by our history, alas. --jhi. */ 5542 # ifdef PWCHANGE 5543 mPUSHi(pwent->pw_change); 5544 # elif defined(PWQUOTA) 5545 mPUSHi(pwent->pw_quota); 5546 # elif defined(PWAGE) 5547 mPUSHs(newSVpv(pwent->pw_age, 0)); 5548 # else 5549 /* I think that you can never get this compiled, but just in case. */ 5550 PUSHs(sv_mortalcopy(&PL_sv_no)); 5551 # endif 5552 5553 /* pw_class and pw_comment are mutually exclusive--. 5554 * see the above note for pw_change, pw_quota, and pw_age. */ 5555 # ifdef PWCLASS 5556 mPUSHs(newSVpv(pwent->pw_class, 0)); 5557 # elif defined(PWCOMMENT) 5558 mPUSHs(newSVpv(pwent->pw_comment, 0)); 5559 # else 5560 /* I think that you can never get this compiled, but just in case. */ 5561 PUSHs(sv_mortalcopy(&PL_sv_no)); 5562 # endif 5563 5564 # ifdef PWGECOS 5565 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0))); 5566 # else 5567 PUSHs(sv = sv_mortalcopy(&PL_sv_no)); 5568 # endif 5569 /* pw_gecos is tainted because user himself can diddle with it. */ 5570 SvTAINTED_on(sv); 5571 5572 mPUSHs(newSVpv(pwent->pw_dir, 0)); 5573 5574 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0))); 5575 /* pw_shell is tainted because user himself can diddle with it. */ 5576 SvTAINTED_on(sv); 5577 5578 # ifdef PWEXPIRE 5579 mPUSHi(pwent->pw_expire); 5580 # endif 5581 } 5582 RETURN; 5583 #else 5584 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5585 #endif 5586 } 5587 5588 5589 /* also used for: pp_ggrgid() pp_ggrnam() */ 5590 5591 PP(pp_ggrent) 5592 { 5593 #ifdef HAS_GROUP 5594 dSP; 5595 const I32 which = PL_op->op_type; 5596 const struct group *grent; 5597 5598 if (which == OP_GGRNAM) { 5599 const char* const name = POPpbytex; 5600 grent = (const struct group *)getgrnam(name); 5601 } 5602 else if (which == OP_GGRGID) { 5603 #if Gid_t_sign == 1 5604 const Gid_t gid = POPu; 5605 #elif Gid_t_sign == -1 5606 const Gid_t gid = POPi; 5607 #else 5608 # error "Unexpected Gid_t_sign" 5609 #endif 5610 grent = (const struct group *)getgrgid(gid); 5611 } 5612 else 5613 #ifdef HAS_GETGRENT 5614 grent = (struct group *)getgrent(); 5615 #else 5616 DIE(aTHX_ PL_no_func, "getgrent"); 5617 #endif 5618 5619 EXTEND(SP, 4); 5620 if (GIMME_V != G_ARRAY) { 5621 SV * const sv = sv_newmortal(); 5622 5623 PUSHs(sv); 5624 if (grent) { 5625 if (which == OP_GGRNAM) 5626 sv_setgid(sv, grent->gr_gid); 5627 else 5628 sv_setpv(sv, grent->gr_name); 5629 } 5630 RETURN; 5631 } 5632 5633 if (grent) { 5634 mPUSHs(newSVpv(grent->gr_name, 0)); 5635 5636 #ifdef GRPASSWD 5637 mPUSHs(newSVpv(grent->gr_passwd, 0)); 5638 #else 5639 PUSHs(sv_mortalcopy(&PL_sv_no)); 5640 #endif 5641 5642 sv_setgid(PUSHmortal, grent->gr_gid); 5643 5644 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API)) 5645 /* In UNICOS/mk (_CRAYMPP) the multithreading 5646 * versions (getgrnam_r, getgrgid_r) 5647 * seem to return an illegal pointer 5648 * as the group members list, gr_mem. 5649 * getgrent() doesn't even have a _r version 5650 * but the gr_mem is poisonous anyway. 5651 * So yes, you cannot get the list of group 5652 * members if building multithreaded in UNICOS/mk. */ 5653 PUSHs(space_join_names_mortal(grent->gr_mem)); 5654 #endif 5655 } 5656 5657 RETURN; 5658 #else 5659 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); 5660 #endif 5661 } 5662 5663 PP(pp_getlogin) 5664 { 5665 #ifdef HAS_GETLOGIN 5666 dSP; dTARGET; 5667 char *tmps; 5668 EXTEND(SP, 1); 5669 if (!(tmps = PerlProc_getlogin())) 5670 RETPUSHUNDEF; 5671 sv_setpv_mg(TARG, tmps); 5672 PUSHs(TARG); 5673 RETURN; 5674 #else 5675 DIE(aTHX_ PL_no_func, "getlogin"); 5676 #endif 5677 } 5678 5679 /* Miscellaneous. */ 5680 5681 PP(pp_syscall) 5682 { 5683 #ifdef HAS_SYSCALL 5684 dSP; dMARK; dORIGMARK; dTARGET; 5685 I32 items = SP - MARK; 5686 unsigned long a[20]; 5687 I32 i = 0; 5688 IV retval = -1; 5689 5690 if (TAINTING_get) { 5691 while (++MARK <= SP) { 5692 if (SvTAINTED(*MARK)) { 5693 TAINT; 5694 break; 5695 } 5696 } 5697 MARK = ORIGMARK; 5698 TAINT_PROPER("syscall"); 5699 } 5700 5701 /* This probably won't work on machines where sizeof(long) != sizeof(int) 5702 * or where sizeof(long) != sizeof(char*). But such machines will 5703 * not likely have syscall implemented either, so who cares? 5704 */ 5705 while (++MARK <= SP) { 5706 if (SvNIOK(*MARK) || !i) 5707 a[i++] = SvIV(*MARK); 5708 else if (*MARK == &PL_sv_undef) 5709 a[i++] = 0; 5710 else 5711 a[i++] = (unsigned long)SvPV_force_nolen(*MARK); 5712 if (i > 15) 5713 break; 5714 } 5715 switch (items) { 5716 default: 5717 DIE(aTHX_ "Too many args to syscall"); 5718 case 0: 5719 DIE(aTHX_ "Too few args to syscall"); 5720 case 1: 5721 retval = syscall(a[0]); 5722 break; 5723 case 2: 5724 retval = syscall(a[0],a[1]); 5725 break; 5726 case 3: 5727 retval = syscall(a[0],a[1],a[2]); 5728 break; 5729 case 4: 5730 retval = syscall(a[0],a[1],a[2],a[3]); 5731 break; 5732 case 5: 5733 retval = syscall(a[0],a[1],a[2],a[3],a[4]); 5734 break; 5735 case 6: 5736 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]); 5737 break; 5738 case 7: 5739 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); 5740 break; 5741 case 8: 5742 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); 5743 break; 5744 } 5745 SP = ORIGMARK; 5746 PUSHi(retval); 5747 RETURN; 5748 #else 5749 DIE(aTHX_ PL_no_func, "syscall"); 5750 #endif 5751 } 5752 5753 #ifdef FCNTL_EMULATE_FLOCK 5754 5755 /* XXX Emulate flock() with fcntl(). 5756 What's really needed is a good file locking module. 5757 */ 5758 5759 static int 5760 fcntl_emulate_flock(int fd, int operation) 5761 { 5762 int res; 5763 struct flock flock; 5764 5765 switch (operation & ~LOCK_NB) { 5766 case LOCK_SH: 5767 flock.l_type = F_RDLCK; 5768 break; 5769 case LOCK_EX: 5770 flock.l_type = F_WRLCK; 5771 break; 5772 case LOCK_UN: 5773 flock.l_type = F_UNLCK; 5774 break; 5775 default: 5776 errno = EINVAL; 5777 return -1; 5778 } 5779 flock.l_whence = SEEK_SET; 5780 flock.l_start = flock.l_len = (Off_t)0; 5781 5782 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); 5783 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES))) 5784 errno = EWOULDBLOCK; 5785 return res; 5786 } 5787 5788 #endif /* FCNTL_EMULATE_FLOCK */ 5789 5790 #ifdef LOCKF_EMULATE_FLOCK 5791 5792 /* XXX Emulate flock() with lockf(). This is just to increase 5793 portability of scripts. The calls are not completely 5794 interchangeable. What's really needed is a good file 5795 locking module. 5796 */ 5797 5798 /* The lockf() constants might have been defined in <unistd.h>. 5799 Unfortunately, <unistd.h> causes troubles on some mixed 5800 (BSD/POSIX) systems, such as SunOS 4.1.3. 5801 5802 Further, the lockf() constants aren't POSIX, so they might not be 5803 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll 5804 just stick in the SVID values and be done with it. Sigh. 5805 */ 5806 5807 # ifndef F_ULOCK 5808 # define F_ULOCK 0 /* Unlock a previously locked region */ 5809 # endif 5810 # ifndef F_LOCK 5811 # define F_LOCK 1 /* Lock a region for exclusive use */ 5812 # endif 5813 # ifndef F_TLOCK 5814 # define F_TLOCK 2 /* Test and lock a region for exclusive use */ 5815 # endif 5816 # ifndef F_TEST 5817 # define F_TEST 3 /* Test a region for other processes locks */ 5818 # endif 5819 5820 static int 5821 lockf_emulate_flock(int fd, int operation) 5822 { 5823 int i; 5824 Off_t pos; 5825 dSAVE_ERRNO; 5826 5827 /* flock locks entire file so for lockf we need to do the same */ 5828 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ 5829 if (pos > 0) /* is seekable and needs to be repositioned */ 5830 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) 5831 pos = -1; /* seek failed, so don't seek back afterwards */ 5832 RESTORE_ERRNO; 5833 5834 switch (operation) { 5835 5836 /* LOCK_SH - get a shared lock */ 5837 case LOCK_SH: 5838 /* LOCK_EX - get an exclusive lock */ 5839 case LOCK_EX: 5840 i = lockf (fd, F_LOCK, 0); 5841 break; 5842 5843 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */ 5844 case LOCK_SH|LOCK_NB: 5845 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */ 5846 case LOCK_EX|LOCK_NB: 5847 i = lockf (fd, F_TLOCK, 0); 5848 if (i == -1) 5849 if ((errno == EAGAIN) || (errno == EACCES)) 5850 errno = EWOULDBLOCK; 5851 break; 5852 5853 /* LOCK_UN - unlock (non-blocking is a no-op) */ 5854 case LOCK_UN: 5855 case LOCK_UN|LOCK_NB: 5856 i = lockf (fd, F_ULOCK, 0); 5857 break; 5858 5859 /* Default - can't decipher operation */ 5860 default: 5861 i = -1; 5862 errno = EINVAL; 5863 break; 5864 } 5865 5866 if (pos > 0) /* need to restore position of the handle */ 5867 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */ 5868 5869 return (i); 5870 } 5871 5872 #endif /* LOCKF_EMULATE_FLOCK */ 5873 5874 /* 5875 * ex: set ts=8 sts=4 sw=4 et: 5876 */ 5877