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