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