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