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