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