1 /* pp_sys.c 2 * 3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 <- <- 42 * and another MAXINT from "perl.h" <- . */ 43 # undef MAXINT 44 # endif 45 # include 46 #endif 47 48 #ifdef I_SYS_WAIT 49 # include 50 #endif 51 52 #ifdef I_SYS_RESOURCE 53 # include 54 #endif 55 56 #ifdef NETWARE 57 NETDB_DEFINE_CONTEXT 58 #endif 59 60 #ifdef HAS_SELECT 61 # ifdef I_SYS_SELECT 62 # include 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 . 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 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 (void); 91 #endif 92 # endif 93 #endif 94 95 #ifdef HAS_GROUP 96 # ifdef I_GRP 97 # include 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 112 # else 113 # include 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 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 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_R_OK /* EFFective uid/gid ACCESS R_OK */ 201 #undef PERL_EFF_ACCESS_W_OK 202 #undef PERL_EFF_ACCESS_X_OK 203 204 /* AIX 5.2 and below use mktime for localtime, and defines the edge case 205 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64 206 * available in the 32bit environment, which could warrant Configure 207 * checks in the future. 208 */ 209 #ifdef _AIX 210 #define LOCALTIME_EDGECASE_BROKEN 211 #endif 212 213 /* F_OK unused: if stat() cannot find it... */ 214 215 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK) 216 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */ 217 # define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK)) 218 # define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK)) 219 # define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK)) 220 #endif 221 222 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS) 223 # ifdef I_SYS_SECURITY 224 # include 225 # endif 226 # ifdef ACC_SELF 227 /* HP SecureWare */ 228 # define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF)) 229 # define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF)) 230 # define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF)) 231 # else 232 /* SCO */ 233 # define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK)) 234 # define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK)) 235 # define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK)) 236 # endif 237 #endif 238 239 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF) 240 /* AIX */ 241 # define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF)) 242 # define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF)) 243 # define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF)) 244 #endif 245 246 #if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \ 247 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \ 248 || defined(HAS_SETREGID) || defined(HAS_SETRESGID)) 249 /* The Hard Way. */ 250 STATIC int 251 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) 252 ###### { 253 ###### Uid_t ruid = getuid(); 254 ###### Uid_t euid = geteuid(); 255 ###### Gid_t rgid = getgid(); 256 ###### Gid_t egid = getegid(); 257 ###### int res; 258 259 LOCK_CRED_MUTEX; 260 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) 261 Perl_croak(aTHX_ "switching effective uid is not implemented"); 262 #else 263 #ifdef HAS_SETREUID 264 ###### if (setreuid(euid, ruid)) 265 #else 266 #ifdef HAS_SETRESUID 267 if (setresuid(euid, ruid, (Uid_t)-1)) 268 #endif 269 #endif 270 ###### Perl_croak(aTHX_ "entering effective uid failed"); 271 #endif 272 273 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID) 274 Perl_croak(aTHX_ "switching effective gid is not implemented"); 275 #else 276 #ifdef HAS_SETREGID 277 ###### if (setregid(egid, rgid)) 278 #else 279 #ifdef HAS_SETRESGID 280 if (setresgid(egid, rgid, (Gid_t)-1)) 281 #endif 282 #endif 283 ###### Perl_croak(aTHX_ "entering effective gid failed"); 284 #endif 285 286 ###### res = access(path, mode); 287 288 #ifdef HAS_SETREUID 289 ###### if (setreuid(ruid, euid)) 290 #else 291 #ifdef HAS_SETRESUID 292 if (setresuid(ruid, euid, (Uid_t)-1)) 293 #endif 294 #endif 295 ###### Perl_croak(aTHX_ "leaving effective uid failed"); 296 297 #ifdef HAS_SETREGID 298 ###### if (setregid(rgid, egid)) 299 #else 300 #ifdef HAS_SETRESGID 301 if (setresgid(rgid, egid, (Gid_t)-1)) 302 #endif 303 #endif 304 ###### Perl_croak(aTHX_ "leaving effective gid failed"); 305 UNLOCK_CRED_MUTEX; 306 307 ###### return res; 308 } 309 # define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK)) 310 # define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK)) 311 # define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK)) 312 #endif 313 314 #if !defined(PERL_EFF_ACCESS_R_OK) 315 /* With it or without it: anyway you get a warning: either that 316 it is unused, or it is declared static and never defined. 317 */ 318 STATIC int 319 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) 320 { 321 (void)path; 322 (void)mode; 323 Perl_croak(aTHX_ "switching effective uid is not implemented"); 324 /*NOTREACHED*/ 325 return -1; 326 } 327 #endif 328 329 PP(pp_backtick) 330 3155 { 331 3155 dSP; dTARGET; 332 3155 PerlIO *fp; 333 3155 const char * const tmps = POPpconstx; 334 3155 const I32 gimme = GIMME_V; 335 3155 const char *mode = "r"; 336 337 3155 TAINT_PROPER("``"); 338 3154 if (PL_op->op_private & OPpOPEN_IN_RAW) 339 ###### mode = "rb"; 340 3154 else if (PL_op->op_private & OPpOPEN_IN_CRLF) 341 ###### mode = "rt"; 342 3154 fp = PerlProc_popen((char*)tmps, (char *)mode); 343 3146 if (fp) { 344 3145 const char *type = NULL; 345 3145 if (PL_curcop->cop_io) { 346 ###### type = SvPV_nolen_const(PL_curcop->cop_io); 347 } 348 3145 if (type && *type) 349 ###### PerlIO_apply_layers(aTHX_ fp,mode,type); 350 351 3145 if (gimme == G_VOID) { 352 17 char tmpbuf[256]; 353 17 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) 354 ; 355 } 356 3136 else if (gimme == G_SCALAR) { 357 1926 ENTER; 358 1926 SAVESPTR(PL_rs); 359 1926 PL_rs = &PL_sv_undef; 360 1926 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */ 361 3676 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) 362 ; 363 1925 LEAVE; 364 1925 XPUSHs(TARG); 365 1925 SvTAINTED_on(TARG); 366 } 367 else { 368 8862 for (;;) { 369 8862 SV * const sv = NEWSV(56, 79); 370 8862 if (sv_gets(sv, fp, 0) == Nullch) { 371 1210 SvREFCNT_dec(sv); 372 ###### break; 373 } 374 7652 XPUSHs(sv_2mortal(sv)); 375 7652 if (SvLEN(sv) - SvCUR(sv) > 20) { 376 6431 SvPV_shrink_to_cur(sv); 377 } 378 7652 SvTAINTED_on(sv); 379 } 380 } 381 3144 STATUS_NATIVE_SET(PerlProc_pclose(fp)); 382 3144 TAINT; /* "I believe that this is not gratuitous!" */ 383 } 384 else { 385 1 STATUS_NATIVE_SET(-1); 386 1 if (gimme == G_SCALAR) 387 ###### RETPUSHUNDEF; 388 } 389 390 3145 RETURN; 391 } 392 393 PP(pp_glob) 394 3 { 395 dVAR; 396 3 OP *result; 397 3 tryAMAGICunTARGET(iter, -1); 398 399 /* Note that we only ever get here if File::Glob fails to load 400 * without at the same time croaking, for some reason, or if 401 * perl was built with PERL_EXTERNAL_GLOB */ 402 403 3 ENTER; 404 405 #ifndef VMS 406 3 if (PL_tainting) { 407 /* 408 * The external globbing program may use things we can't control, 409 * so for security reasons we must assume the worst. 410 */ 411 ###### TAINT; 412 ###### taint_proper(PL_no_security, "glob"); 413 } 414 #endif /* !VMS */ 415 416 3 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */ 417 3 PL_last_in_gv = (GV*)*PL_stack_sp--; 418 419 3 SAVESPTR(PL_rs); /* This is not permanent, either. */ 420 3 PL_rs = sv_2mortal(newSVpvn("\000", 1)); 421 #ifndef DOSISH 422 #ifndef CSH 423 *SvPVX(PL_rs) = '\n'; 424 #endif /* !CSH */ 425 #endif /* !DOSISH */ 426 427 3 result = do_readline(); 428 3 LEAVE; 429 3 return result; 430 } 431 432 PP(pp_rcatline) 433 165 { 434 165 PL_last_in_gv = cGVOP_gv; 435 165 return do_readline(); 436 } 437 438 PP(pp_warn) 439 300 { 440 300 dSP; dMARK; 441 300 SV *tmpsv; 442 300 const char *tmps; 443 300 STRLEN len; 444 300 if (SP - MARK != 1) { 445 21 dTARGET; 446 21 do_join(TARG, &PL_sv_no, MARK, SP); 447 21 tmpsv = TARG; 448 21 SP = MARK + 1; 449 } 450 else { 451 279 tmpsv = TOPs; 452 } 453 300 tmps = SvPV_const(tmpsv, len); 454 300 if ((!tmps || !len) && PL_errgv) { 455 9 SV * const error = ERRSV; 456 9 SvUPGRADE(error, SVt_PV); 457 9 if (SvPOK(error) && SvCUR(error)) 458 ###### sv_catpv(error, "\t...caught"); 459 9 tmpsv = error; 460 9 tmps = SvPV_const(tmpsv, len); 461 } 462 300 if (!tmps || !len) 463 9 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26)); 464 465 300 Perl_warn(aTHX_ "%"SVf, tmpsv); 466 295 RETSETYES; 467 } 468 469 PP(pp_die) 470 1065 { 471 1065 dSP; dMARK; 472 1065 const char *tmps; 473 1065 SV *tmpsv; 474 1065 STRLEN len; 475 1065 bool multiarg = 0; 476 #ifdef VMS 477 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); 478 #endif 479 1065 if (SP - MARK != 1) { 480 57 dTARGET; 481 57 do_join(TARG, &PL_sv_no, MARK, SP); 482 57 tmpsv = TARG; 483 57 tmps = SvPV_const(tmpsv, len); 484 57 multiarg = 1; 485 57 SP = MARK + 1; 486 } 487 else { 488 1008 tmpsv = TOPs; 489 1008 tmps = SvROK(tmpsv) ? Nullch : SvPV_const(tmpsv, len); 490 } 491 1065 if (!tmps || !len) { 492 86 SV *error = ERRSV; 493 86 SvUPGRADE(error, SVt_PV); 494 86 if (multiarg ? SvROK(error) : SvROK(tmpsv)) { 495 6 if (!multiarg) 496 4 SvSetSV(error,tmpsv); 497 2 else if (sv_isobject(error)) { 498 1 HV *stash = SvSTASH(SvRV(error)); 499 1 GV *gv = gv_fetchmethod(stash, "PROPAGATE"); 500 1 if (gv) { 501 1 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); 502 1 SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); 503 1 EXTEND(SP, 3); 504 1 PUSHMARK(SP); 505 1 PUSHs(error); 506 1 PUSHs(file); 507 1 PUSHs(line); 508 1 PUTBACK; 509 1 call_sv((SV*)GvCV(gv), 510 G_SCALAR|G_EVAL|G_KEEPERR); 511 1 sv_setsv(error,*PL_stack_sp--); 512 } 513 } 514 6 DIE_NULL; 515 } 516 else { 517 80 if (SvPOK(error) && SvCUR(error)) 518 ###### sv_catpv(error, "\t...propagated"); 519 80 tmpsv = error; 520 80 tmps = SvPV_const(tmpsv, len); 521 } 522 } 523 1059 if (!tmps || !len) 524 80 tmpsv = sv_2mortal(newSVpvn("Died", 4)); 525 526 1059 DIE(aTHX_ "%"SVf, tmpsv); 527 } 528 529 /* I/O. */ 530 531 PP(pp_open) 532 18839 { 533 18839 dVAR; dSP; 534 18839 dMARK; dORIGMARK; 535 18839 dTARGET; 536 18839 GV *gv; 537 18839 SV *sv; 538 18839 IO *io; 539 18839 const char *tmps; 540 18839 STRLEN len; 541 18839 MAGIC *mg; 542 18839 bool ok; 543 544 18839 gv = (GV *)*++MARK; 545 18839 if (!isGV(gv)) 546 ###### DIE(aTHX_ PL_no_usym, "filehandle"); 547 18839 if ((io = GvIOp(gv))) 548 14243 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; 549 550 18839 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { 551 /* Method's args are same as ours ... */ 552 /* ... except handle is replaced by the object */ 553 2 *MARK-- = SvTIED_obj((SV*)io, mg); 554 2 PUSHMARK(MARK); 555 2 PUTBACK; 556 2 ENTER; 557 2 call_method("OPEN", G_SCALAR); 558 2 LEAVE; 559 2 SPAGAIN; 560 2 RETURN; 561 } 562 563 18837 if (MARK < SP) { 564 18827 sv = *++MARK; 565 } 566 else { 567 10 sv = GvSVn(gv); 568 } 569 570 18837 tmps = SvPV_const(sv, len); 571 18837 ok = do_openn(gv, (char *)tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK)); 572 18851 SP = ORIGMARK; 573 18851 if (ok) 574 18120 PUSHi( (I32)PL_forkprocess ); 575 731 else if (PL_forkprocess == 0) /* we are a new child */ 576 23 PUSHi(0); 577 else 578 708 RETPUSHUNDEF; 579 18143 RETURN; 580 } 581 582 PP(pp_close) 583 18183 { 584 18183 dVAR; dSP; 585 18183 GV *gv; 586 18183 IO *io; 587 18183 MAGIC *mg; 588 589 18183 if (MAXARG == 0) 590 ###### gv = PL_defoutgv; 591 else 592 18183 gv = (GV*)POPs; 593 594 18183 if (gv && (io = GvIO(gv)) 595 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 596 { 597 9 PUSHMARK(SP); 598 9 XPUSHs(SvTIED_obj((SV*)io, mg)); 599 9 PUTBACK; 600 9 ENTER; 601 9 call_method("CLOSE", G_SCALAR); 602 9 LEAVE; 603 9 SPAGAIN; 604 9 RETURN; 605 } 606 18174 EXTEND(SP, 1); 607 18174 PUSHs(boolSV(do_close(gv, TRUE))); 608 18173 RETURN; 609 } 610 611 PP(pp_pipe_op) 612 69 { 613 #ifdef HAS_PIPE 614 69 dSP; 615 69 GV *rgv; 616 69 GV *wgv; 617 69 register IO *rstio; 618 69 register IO *wstio; 619 69 int fd[2]; 620 621 69 wgv = (GV*)POPs; 622 69 rgv = (GV*)POPs; 623 624 69 if (!rgv || !wgv) 625 ###### goto badexit; 626 627 69 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV) 628 ###### DIE(aTHX_ PL_no_usym, "filehandle"); 629 69 rstio = GvIOn(rgv); 630 69 wstio = GvIOn(wgv); 631 632 69 if (IoIFP(rstio)) 633 4 do_close(rgv, FALSE); 634 69 if (IoIFP(wstio)) 635 6 do_close(wgv, FALSE); 636 637 69 if (PerlProc_pipe(fd) < 0) 638 ###### goto badexit; 639 640 69 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE); 641 69 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE); 642 69 IoOFP(rstio) = IoIFP(rstio); 643 69 IoIFP(wstio) = IoOFP(wstio); 644 69 IoTYPE(rstio) = IoTYPE_RDONLY; 645 69 IoTYPE(wstio) = IoTYPE_WRONLY; 646 647 69 if (!IoIFP(rstio) || !IoOFP(wstio)) { 648 ###### if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); 649 ###### else PerlLIO_close(fd[0]); 650 ###### if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); 651 ###### else PerlLIO_close(fd[1]); 652 ###### goto badexit; 653 } 654 #if defined(HAS_FCNTL) && defined(F_SETFD) 655 69 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ 656 69 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ 657 #endif 658 69 RETPUSHYES; 659 660 badexit: 661 ###### RETPUSHUNDEF; 662 #else 663 DIE(aTHX_ PL_no_func, "pipe"); 664 #endif 665 } 666 667 PP(pp_fileno) 668 311 { 669 311 dVAR; dSP; dTARGET; 670 311 GV *gv; 671 311 IO *io; 672 311 PerlIO *fp; 673 311 MAGIC *mg; 674 675 311 if (MAXARG < 1) 676 ###### RETPUSHUNDEF; 677 311 gv = (GV*)POPs; 678 679 311 if (gv && (io = GvIO(gv)) 680 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 681 { 682 ###### PUSHMARK(SP); 683 ###### XPUSHs(SvTIED_obj((SV*)io, mg)); 684 ###### PUTBACK; 685 ###### ENTER; 686 ###### call_method("FILENO", G_SCALAR); 687 ###### LEAVE; 688 ###### SPAGAIN; 689 ###### RETURN; 690 } 691 692 311 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) { 693 /* Can't do this because people seem to do things like 694 defined(fileno($foo)) to check whether $foo is a valid fh. 695 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 696 report_evil_fh(gv, io, PL_op->op_type); 697 */ 698 34 RETPUSHUNDEF; 699 } 700 701 277 PUSHi(PerlIO_fileno(fp)); 702 277 RETURN; 703 } 704 705 PP(pp_umask) 706 139 { 707 139 dSP; 708 #ifdef HAS_UMASK 709 139 dTARGET; 710 139 Mode_t anum; 711 712 139 if (MAXARG < 1) { 713 47 anum = PerlLIO_umask(0); 714 47 (void)PerlLIO_umask(anum); 715 } 716 else 717 92 anum = PerlLIO_umask(POPi); 718 139 TAINT_PROPER("umask"); 719 139 XPUSHi(anum); 720 #else 721 /* Only DIE if trying to restrict permissions on "user" (self). 722 * Otherwise it's harmless and more useful to just return undef 723 * since 'group' and 'other' concepts probably don't exist here. */ 724 if (MAXARG >= 1 && (POPi & 0700)) 725 DIE(aTHX_ "umask not implemented"); 726 XPUSHs(&PL_sv_undef); 727 #endif 728 139 RETURN; 729 } 730 731 PP(pp_binmode) 732 11018 { 733 11018 dVAR; dSP; 734 11018 GV *gv; 735 11018 IO *io; 736 11018 PerlIO *fp; 737 11018 MAGIC *mg; 738 11018 SV *discp = Nullsv; 739 740 11018 if (MAXARG < 1) 741 ###### RETPUSHUNDEF; 742 11018 if (MAXARG > 1) { 743 972 discp = POPs; 744 } 745 746 11018 gv = (GV*)POPs; 747 748 11018 if (gv && (io = GvIO(gv)) 749 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 750 { 751 1 PUSHMARK(SP); 752 1 XPUSHs(SvTIED_obj((SV*)io, mg)); 753 1 if (discp) 754 ###### XPUSHs(discp); 755 1 PUTBACK; 756 1 ENTER; 757 1 call_method("BINMODE", G_SCALAR); 758 1 LEAVE; 759 1 SPAGAIN; 760 1 RETURN; 761 } 762 763 11017 EXTEND(SP, 1); 764 11017 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) { 765 3 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 766 2 report_evil_fh(gv, io, PL_op->op_type); 767 3 SETERRNO(EBADF,RMS_IFI); 768 3 RETPUSHUNDEF; 769 } 770 771 11014 PUTBACK; 772 11014 if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), 773 (discp) ? SvPV_nolen_const(discp) : Nullch)) { 774 11012 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { 775 8 if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io), 776 mode_from_discipline(discp), 777 (discp) ? SvPV_nolen_const(discp) : Nullch)) { 778 ###### SPAGAIN; 779 ###### RETPUSHUNDEF; 780 } 781 } 782 11012 SPAGAIN; 783 11012 RETPUSHYES; 784 } 785 else { 786 2 SPAGAIN; 787 2 RETPUSHUNDEF; 788 } 789 } 790 791 PP(pp_tie) 792 5331 { 793 5331 dVAR; dSP; dMARK; 794 5331 SV *varsv; 795 5331 HV* stash; 796 5331 GV *gv; 797 5331 SV *sv; 798 5331 const I32 markoff = MARK - PL_stack_base; 799 5331 const char *methname; 800 5331 int how = PERL_MAGIC_tied; 801 5331 U32 items; 802 803 5331 varsv = *++MARK; 804 5331 switch(SvTYPE(varsv)) { 805 case SVt_PVHV: 806 1836 methname = "TIEHASH"; 807 1836 HvEITER_set((HV *)varsv, 0); 808 1836 break; 809 case SVt_PVAV: 810 3035 methname = "TIEARRAY"; 811 3035 break; 812 case SVt_PVGV: 813 #ifdef GV_UNIQUE_CHECK 814 if (GvUNIQUE((GV*)varsv)) { 815 Perl_croak(aTHX_ "Attempt to tie unique GV"); 816 } 817 #endif 818 260 methname = "TIEHANDLE"; 819 260 how = PERL_MAGIC_tiedscalar; 820 /* For tied filehandles, we apply tiedscalar magic to the IO 821 slot of the GP rather than the GV itself. AMS 20010812 */ 822 260 if (!GvIOp(varsv)) 823 118 GvIOp(varsv) = newIO(); 824 260 varsv = (SV *)GvIOp(varsv); 825 260 break; 826 default: 827 200 methname = "TIESCALAR"; 828 200 how = PERL_MAGIC_tiedscalar; 829 5331 break; 830 } 831 5331 items = SP - MARK++; 832 5331 if (sv_isobject(*MARK)) { 833 ###### ENTER; 834 ###### PUSHSTACKi(PERLSI_MAGIC); 835 ###### PUSHMARK(SP); 836 ###### EXTEND(SP,(I32)items); 837 ###### while (items--) 838 ###### PUSHs(*MARK++); 839 ###### PUTBACK; 840 ###### call_method(methname, G_SCALAR); 841 } 842 else { 843 /* Not clear why we don't call call_method here too. 844 * perhaps to get different error message ? 845 */ 846 5331 stash = gv_stashsv(*MARK, FALSE); 847 5331 if (!stash || !(gv = gv_fetchmethod(stash, methname))) { 848 1 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", 849 methname, *MARK); 850 } 851 5330 ENTER; 852 5330 PUSHSTACKi(PERLSI_MAGIC); 853 5330 PUSHMARK(SP); 854 5330 EXTEND(SP,(I32)items); 855 15607 while (items--) 856 10277 PUSHs(*MARK++); 857 5330 PUTBACK; 858 5330 call_sv((SV*)GvCV(gv), G_SCALAR); 859 } 860 5326 SPAGAIN; 861 862 5326 sv = TOPs; 863 5326 POPSTACK; 864 5326 if (sv_isobject(sv)) { 865 5320 sv_unmagic(varsv, how); 866 /* Croak if a self-tie on an aggregate is attempted. */ 867 5320 if (varsv == SvRV(sv) && 868 (SvTYPE(varsv) == SVt_PVAV || 869 SvTYPE(varsv) == SVt_PVHV)) 870 1 Perl_croak(aTHX_ 871 "Self-ties of arrays and hashes are not supported"); 872 5319 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0); 873 } 874 5325 LEAVE; 875 5325 SP = PL_stack_base + markoff; 876 5325 PUSHs(sv); 877 5325 RETURN; 878 } 879 880 PP(pp_untie) 881 3193 { 882 3193 dVAR; dSP; 883 3193 MAGIC *mg; 884 3193 SV *sv = POPs; 885 3193 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) 886 3193 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; 887 888 3193 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) 889 ###### RETPUSHYES; 890 891 3193 if ((mg = SvTIED_mg(sv, how))) { 892 3111 SV * const obj = SvRV(SvTIED_obj(sv, mg)); 893 3111 GV *gv; 894 3111 CV *cv = NULL; 895 3111 if (obj) { 896 3110 if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && 897 isGV(gv) && (cv = GvCV(gv))) { 898 49 PUSHMARK(SP); 899 49 XPUSHs(SvTIED_obj((SV*)gv, mg)); 900 49 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); 901 49 PUTBACK; 902 49 ENTER; 903 49 call_sv((SV *)cv, G_VOID); 904 49 LEAVE; 905 49 SPAGAIN; 906 } 907 3061 else if (ckWARN(WARN_UNTIE)) { 908 64 if (mg && SvREFCNT(obj) > 1) 909 4 Perl_warner(aTHX_ packWARN(WARN_UNTIE), 910 "untie attempted while %"UVuf" inner references still exist", 911 (UV)SvREFCNT(obj) - 1 ) ; 912 } 913 } 914 } 915 3193 sv_unmagic(sv, how) ; 916 3193 RETPUSHYES; 917 } 918 919 PP(pp_tied) 920 1088 { 921 1088 dSP; 922 1088 const MAGIC *mg; 923 1088 SV *sv = POPs; 924 1088 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) 925 1088 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; 926 927 1088 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) 928 3 RETPUSHUNDEF; 929 930 1085 if ((mg = SvTIED_mg(sv, how))) { 931 792 SV *osv = SvTIED_obj(sv, mg); 932 792 if (osv == mg->mg_obj) 933 792 osv = sv_mortalcopy(osv); 934 792 PUSHs(osv); 935 792 RETURN; 936 } 937 293 RETPUSHUNDEF; 938 } 939 940 PP(pp_dbmopen) 941 1 { 942 1 dVAR; dSP; 943 1 dPOPPOPssrl; 944 1 HV* stash; 945 1 GV *gv; 946 1 SV *sv; 947 948 1 HV * const hv = (HV*)POPs; 949 950 1 sv = sv_mortalcopy(&PL_sv_no); 951 1 sv_setpv(sv, "AnyDBM_File"); 952 1 stash = gv_stashsv(sv, FALSE); 953 1 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { 954 ###### PUTBACK; 955 ###### require_pv("AnyDBM_File.pm"); 956 ###### SPAGAIN; 957 ###### if (!(gv = gv_fetchmethod(stash, "TIEHASH"))) 958 ###### DIE(aTHX_ "No dbm on this machine"); 959 } 960 961 1 ENTER; 962 1 PUSHMARK(SP); 963 964 1 EXTEND(SP, 5); 965 1 PUSHs(sv); 966 1 PUSHs(left); 967 1 if (SvIV(right)) 968 1 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT))); 969 else 970 ###### PUSHs(sv_2mortal(newSVuv(O_RDWR))); 971 1 PUSHs(right); 972 1 PUTBACK; 973 1 call_sv((SV*)GvCV(gv), G_SCALAR); 974 1 SPAGAIN; 975 976 1 if (!sv_isobject(TOPs)) { 977 ###### SP--; 978 ###### PUSHMARK(SP); 979 ###### PUSHs(sv); 980 ###### PUSHs(left); 981 ###### PUSHs(sv_2mortal(newSVuv(O_RDONLY))); 982 ###### PUSHs(right); 983 ###### PUTBACK; 984 ###### call_sv((SV*)GvCV(gv), G_SCALAR); 985 ###### SPAGAIN; 986 } 987 988 1 if (sv_isobject(TOPs)) { 989 1 sv_unmagic((SV *) hv, PERL_MAGIC_tied); 990 1 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0); 991 } 992 1 LEAVE; 993 1 RETURN; 994 } 995 996 PP(pp_dbmclose) 997 1 { 998 1 return pp_untie(); 999 } 1000 1001 PP(pp_sselect) 1002 65 { 1003 #ifdef HAS_SELECT 1004 65 dSP; dTARGET; 1005 65 register I32 i; 1006 65 register I32 j; 1007 65 register char *s; 1008 65 register SV *sv; 1009 65 NV value; 1010 65 I32 maxlen = 0; 1011 65 I32 nfound; 1012 65 struct timeval timebuf; 1013 65 struct timeval *tbuf = &timebuf; 1014 65 I32 growsize; 1015 65 char *fd_sets[4]; 1016 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1017 I32 masksize; 1018 I32 offset; 1019 I32 k; 1020 1021 # if BYTEORDER & 0xf0000 1022 # define ORDERBYTE (0x88888888 - BYTEORDER) 1023 # else 1024 # define ORDERBYTE (0x4444 - BYTEORDER) 1025 # endif 1026 1027 #endif 1028 1029 65 SP -= 4; 1030 254 for (i = 1; i <= 3; i++) { 1031 192 SV *sv = SP[i]; 1032 192 if (SvOK(sv) && SvREADONLY(sv)) { 1033 3 if (SvIsCOW(sv)) 1034 ###### sv_force_normal_flags(sv, 0); 1035 3 if (SvREADONLY(sv)) 1036 3 DIE(aTHX_ PL_no_modify); 1037 } 1038 189 if (!SvPOK(sv)) 1039 125 continue; 1040 64 j = SvCUR(sv); 1041 64 if (maxlen < j) 1042 54 maxlen = j; 1043 } 1044 1045 /* little endians can use vecs directly */ 1046 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1047 # ifdef NFDBITS 1048 1049 # ifndef NBBY 1050 # define NBBY 8 1051 # endif 1052 1053 masksize = NFDBITS / NBBY; 1054 # else 1055 masksize = sizeof(long); /* documented int, everyone seems to use long */ 1056 # endif 1057 Zero(&fd_sets[0], 4, char*); 1058 #endif 1059 1060 # if SELECT_MIN_BITS == 1 1061 growsize = sizeof(fd_set); 1062 # else 1063 # if defined(__GLIBC__) && defined(__FD_SETSIZE) 1064 # undef SELECT_MIN_BITS 1065 # define SELECT_MIN_BITS __FD_SETSIZE 1066 # endif 1067 /* If SELECT_MIN_BITS is greater than one we most probably will want 1068 * to align the sizes with SELECT_MIN_BITS/8 because for example 1069 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital 1070 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates 1071 * on (sets/tests/clears bits) is 32 bits. */ 1072 62 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); 1073 # endif 1074 1075 62 sv = SP[4]; 1076 62 if (SvOK(sv)) { 1077 41 value = SvNV(sv); 1078 41 if (value < 0.0) 1079 ###### value = 0.0; 1080 41 timebuf.tv_sec = (long)value; 1081 41 value -= (NV)timebuf.tv_sec; 1082 41 timebuf.tv_usec = (long)(value * 1000000.0); 1083 } 1084 else 1085 21 tbuf = Null(struct timeval*); 1086 1087 248 for (i = 1; i <= 3; i++) { 1088 186 sv = SP[i]; 1089 186 if (!SvOK(sv)) { 1090 125 fd_sets[i] = 0; 1091 125 continue; 1092 } 1093 61 else if (!SvPOK(sv)) 1094 ###### SvPV_force_nolen(sv); /* force string conversion */ 1095 61 j = SvLEN(sv); 1096 61 if (j < growsize) { 1097 29 Sv_Grow(sv, growsize); 1098 } 1099 61 j = SvCUR(sv); 1100 61 s = SvPVX(sv) + j; 1101 7814 while (++j <= growsize) { 1102 7753 *s++ = '\0'; 1103 } 1104 1105 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1106 s = SvPVX(sv); 1107 New(403, fd_sets[i], growsize, char); 1108 for (offset = 0; offset < growsize; offset += masksize) { 1109 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) 1110 fd_sets[i][j+offset] = s[(k % masksize) + offset]; 1111 } 1112 #else 1113 61 fd_sets[i] = SvPVX(sv); 1114 #endif 1115 } 1116 1117 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST 1118 /* Can't make just the (void*) conditional because that would be 1119 * cpp #if within cpp macro, and not all compilers like that. */ 1120 nfound = PerlSock_select( 1121 maxlen * 8, 1122 (Select_fd_set_t) fd_sets[1], 1123 (Select_fd_set_t) fd_sets[2], 1124 (Select_fd_set_t) fd_sets[3], 1125 (void*) tbuf); /* Workaround for compiler bug. */ 1126 #else 1127 62 nfound = PerlSock_select( 1128 maxlen * 8, 1129 (Select_fd_set_t) fd_sets[1], 1130 (Select_fd_set_t) fd_sets[2], 1131 (Select_fd_set_t) fd_sets[3], 1132 tbuf); 1133 #endif 1134 248 for (i = 1; i <= 3; i++) { 1135 186 if (fd_sets[i]) { 1136 61 sv = SP[i]; 1137 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 1138 s = SvPVX(sv); 1139 for (offset = 0; offset < growsize; offset += masksize) { 1140 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) 1141 s[(k % masksize) + offset] = fd_sets[i][j+offset]; 1142 } 1143 Safefree(fd_sets[i]); 1144 #endif 1145 61 SvSETMAGIC(sv); 1146 } 1147 } 1148 1149 62 if (nfound == -1) 1150 2 PUSHs(&PL_sv_undef); 1151 else 1152 60 PUSHi(nfound); 1153 62 if (GIMME == G_ARRAY && tbuf) { 1154 ###### value = (NV)(timebuf.tv_sec) + 1155 (NV)(timebuf.tv_usec) / 1000000.0; 1156 ###### PUSHs(sv = sv_mortalcopy(&PL_sv_no)); 1157 ###### sv_setnv(sv, value); 1158 } 1159 62 RETURN; 1160 #else 1161 DIE(aTHX_ "select not implemented"); 1162 #endif 1163 } 1164 1165 void 1166 Perl_setdefout(pTHX_ GV *gv) 1167 18403 { 1168 18403 if (gv) 1169 13854 (void)SvREFCNT_inc(gv); 1170 18403 if (PL_defoutgv) 1171 13900 SvREFCNT_dec(PL_defoutgv); 1172 18403 PL_defoutgv = gv; 1173 } 1174 1175 PP(pp_select) 1176 9193 { 1177 9193 dSP; dTARGET; 1178 9193 GV *egv; 1179 9193 HV *hv; 1180 1181 9193 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL; 1182 1183 9193 egv = GvEGV(PL_defoutgv); 1184 9193 if (!egv) 1185 5 egv = PL_defoutgv; 1186 9193 hv = GvSTASH(egv); 1187 9193 if (! hv) 1188 ###### XPUSHs(&PL_sv_undef); 1189 else { 1190 9193 GV ** const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE); 1191 9193 if (gvp && *gvp == egv) { 1192 6139 gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE); 1193 6139 XPUSHTARG; 1194 } 1195 else { 1196 3054 XPUSHs(sv_2mortal(newRV((SV*)egv))); 1197 } 1198 } 1199 1200 9193 if (newdefout) { 1201 9069 if (!GvIO(newdefout)) 1202 36 gv_IOadd(newdefout); 1203 9069 setdefout(newdefout); 1204 } 1205 1206 9193 RETURN; 1207 } 1208 1209 PP(pp_getc) 1210 317 { 1211 317 dVAR; dSP; dTARGET; 1212 317 IO *io = NULL; 1213 317 MAGIC *mg; 1214 317 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs; 1215 1216 317 if (gv && (io = GvIO(gv)) 1217 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 1218 { 1219 299 const I32 gimme = GIMME_V; 1220 299 PUSHMARK(SP); 1221 299 XPUSHs(SvTIED_obj((SV*)io, mg)); 1222 299 PUTBACK; 1223 299 ENTER; 1224 299 call_method("GETC", gimme); 1225 299 LEAVE; 1226 299 SPAGAIN; 1227 299 if (gimme == G_SCALAR) 1228 299 SvSetMagicSV_nosteal(TARG, TOPs); 1229 299 RETURN; 1230 } 1231 18 if (!gv || do_eof(gv)) { /* make sure we have fp with something */ 1232 7 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) 1233 && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))) 1234 3 report_evil_fh(gv, io, PL_op->op_type); 1235 7 SETERRNO(EBADF,RMS_IFI); 1236 7 RETPUSHUNDEF; 1237 } 1238 11 TAINT; 1239 11 sv_setpvn(TARG, " ", 1); 1240 11 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ 1241 11 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) { 1242 /* Find out how many bytes the char needs */ 1243 3 Size_t len = UTF8SKIP(SvPVX_const(TARG)); 1244 3 if (len > 1) { 1245 2 SvGROW(TARG,len+1); 1246 2 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); 1247 2 SvCUR_set(TARG,1+len); 1248 } 1249 3 SvUTF8_on(TARG); 1250 } 1251 11 PUSHTARG; 1252 11 RETURN; 1253 } 1254 1255 PP(pp_read) 1256 12679 { 1257 12679 return pp_sysread(); 1258 } 1259 1260 STATIC OP * 1261 S_doform(pTHX_ CV *cv, GV *gv, OP *retop) 1262 131 { 1263 dVAR; 1264 131 register PERL_CONTEXT *cx; 1265 131 const I32 gimme = GIMME_V; 1266 1267 131 ENTER; 1268 131 SAVETMPS; 1269 1270 131 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); 1271 131 PUSHFORMAT(cx); 1272 131 cx->blk_sub.retop = retop; 1273 131 SAVECOMPPAD(); 1274 131 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); 1275 1276 131 setdefout(gv); /* locally select filehandle so $% et al work */ 1277 131 return CvSTART(cv); 1278 } 1279 1280 PP(pp_enterwrite) 1281 123 { 1282 123 dSP; 1283 123 register GV *gv; 1284 123 register IO *io; 1285 123 GV *fgv; 1286 123 CV *cv; 1287 1288 123 if (MAXARG == 0) 1289 33 gv = PL_defoutgv; 1290 else { 1291 90 gv = (GV*)POPs; 1292 90 if (!gv) 1293 ###### gv = PL_defoutgv; 1294 } 1295 123 EXTEND(SP, 1); 1296 123 io = GvIO(gv); 1297 123 if (!io) { 1298 ###### RETPUSHNO; 1299 } 1300 123 if (IoFMT_GV(io)) 1301 8 fgv = IoFMT_GV(io); 1302 else 1303 115 fgv = gv; 1304 1305 123 cv = GvFORM(fgv); 1306 123 if (!cv) { 1307 ###### if (fgv) { 1308 ###### SV * const tmpsv = sv_newmortal(); 1309 ###### const char *name; 1310 ###### gv_efullname4(tmpsv, fgv, Nullch, FALSE); 1311 ###### name = SvPV_nolen_const(tmpsv); 1312 ###### if (name && *name) 1313 ###### DIE(aTHX_ "Undefined format \"%s\" called", name); 1314 } 1315 ###### DIE(aTHX_ "Not a format reference"); 1316 } 1317 123 if (CvCLONE(cv)) 1318 35 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 1319 1320 123 IoFLAGS(io) &= ~IOf_DIDTOP; 1321 123 return doform(cv,gv,PL_op->op_next); 1322 } 1323 1324 PP(pp_leavewrite) 1325 138 { 1326 138 dVAR; dSP; 1327 138 GV * const gv = cxstack[cxstack_ix].blk_sub.gv; 1328 138 register IO * const io = GvIOp(gv); 1329 138 PerlIO * const ofp = IoOFP(io); 1330 138 PerlIO *fp; 1331 138 SV **newsp; 1332 138 I32 gimme; 1333 138 register PERL_CONTEXT *cx; 1334 1335 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", 1336 138 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); 1337 138 if (!io || !ofp) 1338 67 goto forget_top; 1339 71 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) && 1340 PL_formtarget != PL_toptarget) 1341 { 1342 36 GV *fgv; 1343 36 CV *cv; 1344 36 if (!IoTOP_GV(io)) { 1345 28 GV *topgv; 1346 1347 28 if (!IoTOP_NAME(io)) { 1348 27 SV *topname; 1349 27 if (!IoFMT_NAME(io)) 1350 25 IoFMT_NAME(io) = savepv(GvNAME(gv)); 1351 27 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv))); 1352 27 topgv = gv_fetchsv(topname, FALSE, SVt_PVFM); 1353 27 if ((topgv && GvFORM(topgv)) || 1354 !gv_fetchpv("top",FALSE,SVt_PVFM)) 1355 27 IoTOP_NAME(io) = savesvpv(topname); 1356 else 1357 ###### IoTOP_NAME(io) = savepvn("top", 3); 1358 } 1359 28 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM); 1360 28 if (!topgv || !GvFORM(topgv)) { 1361 26 IoLINES_LEFT(io) = IoPAGE_LEN(io); 1362 26 goto forget_top; 1363 } 1364 2 IoTOP_GV(io) = topgv; 1365 } 1366 10 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ 1367 5 I32 lines = IoLINES_LEFT(io); 1368 5 const char *s = SvPVX_const(PL_formtarget); 1369 5 if (lines <= 0) /* Yow, header didn't even fit!!! */ 1370 2 goto forget_top; 1371 12 while (lines-- > 0) { 1372 9 s = strchr(s, '\n'); 1373 9 if (!s) 1374 ###### break; 1375 9 s++; 1376 } 1377 3 if (s) { 1378 3 const STRLEN save = SvCUR(PL_formtarget); 1379 3 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget)); 1380 3 do_print(PL_formtarget, ofp); 1381 3 SvCUR_set(PL_formtarget, save); 1382 3 sv_chop(PL_formtarget, s); 1383 3 FmLINES(PL_formtarget) -= IoLINES_LEFT(io); 1384 } 1385 } 1386 8 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) 1387 4 do_print(PL_formfeed, ofp); 1388 8 IoLINES_LEFT(io) = IoPAGE_LEN(io); 1389 8 IoPAGE(io)++; 1390 8 PL_formtarget = PL_toptarget; 1391 8 IoFLAGS(io) |= IOf_DIDTOP; 1392 8 fgv = IoTOP_GV(io); 1393 8 if (!fgv) 1394 ###### DIE(aTHX_ "bad top format reference"); 1395 8 cv = GvFORM(fgv); 1396 8 if (!cv) { 1397 ###### SV * const sv = sv_newmortal(); 1398 ###### const char *name; 1399 ###### gv_efullname4(sv, fgv, Nullch, FALSE); 1400 ###### name = SvPV_nolen_const(sv); 1401 ###### if (name && *name) 1402 ###### DIE(aTHX_ "Undefined top format \"%s\" called",name); 1403 } 1404 /* why no: 1405 else 1406 DIE(aTHX_ "Undefined top format called"); 1407 ?*/ 1408 8 if (CvCLONE(cv)) 1409 5 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 1410 8 return doform(cv,gv,PL_op); 1411 } 1412 1413 forget_top: 1414 130 POPBLOCK(cx,PL_curpm); 1415 130 POPFORMAT(cx); 1416 130 LEAVE; 1417 1418 130 fp = IoOFP(io); 1419 130 if (!fp) { 1420 67 if (ckWARN2(WARN_CLOSED,WARN_IO)) { 1421 3 if (IoIFP(io)) 1422 1 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); 1423 2 else if (ckWARN(WARN_CLOSED)) 1424 2 report_evil_fh(gv, io, PL_op->op_type); 1425 } 1426 67 PUSHs(&PL_sv_no); 1427 } 1428 else { 1429 63 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { 1430 3 if (ckWARN(WARN_IO)) 1431 1 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow"); 1432 } 1433 63 if (!do_print(PL_formtarget, fp)) 1434 ###### PUSHs(&PL_sv_no); 1435 else { 1436 63 FmLINES(PL_formtarget) = 0; 1437 63 SvCUR_set(PL_formtarget, 0); 1438 63 *SvEND(PL_formtarget) = '\0'; 1439 63 if (IoFLAGS(io) & IOf_FLUSH) 1440 11 (void)PerlIO_flush(fp); 1441 63 PUSHs(&PL_sv_yes); 1442 } 1443 } 1444 /* bad_ofp: */ 1445 130 PL_formtarget = PL_bodytarget; 1446 130 PUTBACK; 1447 130 PERL_UNUSED_VAR(newsp); 1448 130 PERL_UNUSED_VAR(gimme); 1449 130 return cx->blk_sub.retop; 1450 } 1451 1452 PP(pp_prtf) 1453 225658 { 1454 225658 dVAR; dSP; dMARK; dORIGMARK; 1455 225658 GV *gv; 1456 225658 IO *io; 1457 225658 PerlIO *fp; 1458 225658 SV *sv; 1459 225658 MAGIC *mg; 1460 1461 225658 if (PL_op->op_flags & OPf_STACKED) 1462 223210 gv = (GV*)*++MARK; 1463 else 1464 2448 gv = PL_defoutgv; 1465 1466 225658 if (gv && (io = GvIO(gv)) 1467 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 1468 { 1469 36 if (MARK == ORIGMARK) { 1470 32 MEXTEND(SP, 1); 1471 32 ++MARK; 1472 32 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); 1473 32 ++SP; 1474 } 1475 36 PUSHMARK(MARK - 1); 1476 36 *MARK = SvTIED_obj((SV*)io, mg); 1477 36 PUTBACK; 1478 36 ENTER; 1479 36 call_method("PRINTF", G_SCALAR); 1480 36 LEAVE; 1481 36 SPAGAIN; 1482 36 MARK = ORIGMARK + 1; 1483 36 *MARK = *SP; 1484 36 SP = MARK; 1485 36 RETURN; 1486 } 1487 1488 225622 sv = NEWSV(0,0); 1489 225622 if (!(io = GvIO(gv))) { 1490 2 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 1491 1 report_evil_fh(gv, io, PL_op->op_type); 1492 2 SETERRNO(EBADF,RMS_IFI); 1493 2 goto just_say_no; 1494 } 1495 225620 else if (!(fp = IoOFP(io))) { 1496 6 if (ckWARN2(WARN_CLOSED,WARN_IO)) { 1497 3 if (IoIFP(io)) 1498 1 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); 1499 2 else if (ckWARN(WARN_CLOSED)) 1500 2 report_evil_fh(gv, io, PL_op->op_type); 1501 } 1502 6 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); 1503 6 goto just_say_no; 1504 } 1505 else { 1506 225614 do_sprintf(sv, SP - MARK, MARK + 1); 1507 225614 if (!do_print(sv, fp)) 1508 ###### goto just_say_no; 1509 1510 225614 if (IoFLAGS(io) & IOf_FLUSH) 1511 1954 if (PerlIO_flush(fp) == EOF) 1512 ###### goto just_say_no; 1513 } 1514 225614 SvREFCNT_dec(sv); 1515 225614 SP = ORIGMARK; 1516 225614 PUSHs(&PL_sv_yes); 1517 225614 RETURN; 1518 1519 just_say_no: 1520 8 SvREFCNT_dec(sv); 1521 8 SP = ORIGMARK; 1522 8 PUSHs(&PL_sv_undef); 1523 8 RETURN; 1524 } 1525 1526 PP(pp_sysopen) 1527 3037 { 1528 3037 dSP; 1529 3037 const int perm = (MAXARG > 3) ? POPi : 0666; 1530 3037 const int mode = POPi; 1531 3037 SV * const sv = POPs; 1532 3037 GV * const gv = (GV *)POPs; 1533 3037 STRLEN len; 1534 1535 /* Need TIEHANDLE method ? */ 1536 3037 const char * const tmps = SvPV_const(sv, len); 1537 /* FIXME? do_open should do const */ 1538 3037 if (do_open(gv, (char*)tmps, len, TRUE, mode, perm, Nullfp)) { 1539 3017 IoLINES(GvIOp(gv)) = 0; 1540 3017 PUSHs(&PL_sv_yes); 1541 } 1542 else { 1543 5 PUSHs(&PL_sv_undef); 1544 } 1545 3022 RETURN; 1546 } 1547 1548 PP(pp_sysread) 1549 13096 { 1550 13096 dVAR; dSP; dMARK; dORIGMARK; dTARGET; 1551 13096 int offset; 1552 13096 IO *io; 1553 13096 char *buffer; 1554 13096 SSize_t length; 1555 13096 SSize_t count; 1556 13096 Sock_size_t bufsize; 1557 13096 SV *bufsv; 1558 13096 STRLEN blen; 1559 13096 int fp_utf8; 1560 13096 int buffer_utf8; 1561 13096 SV *read_target; 1562 13096 Size_t got = 0; 1563 13096 Size_t wanted; 1564 13096 bool charstart = FALSE; 1565 13096 STRLEN charskip = 0; 1566 13096 STRLEN skip = 0; 1567 1568 13096 GV * const gv = (GV*)*++MARK; 1569 13096 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) 1570 && gv && (io = GvIO(gv)) ) 1571 { 1572 13088 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); 1573 13088 if (mg) { 1574 133 SV *sv; 1575 133 PUSHMARK(MARK-1); 1576 133 *MARK = SvTIED_obj((SV*)io, mg); 1577 133 ENTER; 1578 133 call_method("READ", G_SCALAR); 1579 133 LEAVE; 1580 133 SPAGAIN; 1581 133 sv = POPs; 1582 133 SP = ORIGMARK; 1583 133 PUSHs(sv); 1584 133 RETURN; 1585 } 1586 } 1587 1588 12963 if (!gv) 1589 ###### goto say_undef; 1590 12963 bufsv = *++MARK; 1591 12963 if (! SvOK(bufsv)) 1592 11160 sv_setpvn(bufsv, "", 0); 1593 12963 length = SvIVx(*++MARK); 1594 12963 SETERRNO(0,0); 1595 12963 if (MARK < SP) 1596 1293 offset = SvIVx(*++MARK); 1597 else 1598 11670 offset = 0; 1599 12963 io = GvIO(gv); 1600 12963 if (!io || !IoIFP(io)) { 1601 9 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 1602 4 report_evil_fh(gv, io, PL_op->op_type); 1603 9 SETERRNO(EBADF,RMS_IFI); 1604 9 goto say_undef; 1605 } 1606 12954 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { 1607 791 buffer = SvPVutf8_force(bufsv, blen); 1608 /* UTF-8 may not have been set if they are all low bytes */ 1609 791 SvUTF8_on(bufsv); 1610 791 buffer_utf8 = 0; 1611 } 1612 else { 1613 12163 buffer = SvPV_force(bufsv, blen); 1614 12163 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); 1615 } 1616 12954 if (length < 0) 1617 1 DIE(aTHX_ "Negative length"); 1618 12953 wanted = length; 1619 1620 12953 charstart = TRUE; 1621 12953 charskip = 0; 1622 12953 skip = 0; 1623 1624 #ifdef HAS_SOCKET 1625 12953 if (PL_op->op_type == OP_RECV) { 1626 4 char namebuf[MAXPATHLEN]; 1627 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) 1628 bufsize = sizeof (struct sockaddr_in); 1629 #else 1630 4 bufsize = sizeof namebuf; 1631 #endif 1632 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */ 1633 if (bufsize >= 256) 1634 bufsize = 255; 1635 #endif 1636 4 buffer = SvGROW(bufsv, (STRLEN)(length+1)); 1637 /* 'offset' means 'flags' here */ 1638 4 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, 1639 (struct sockaddr *)namebuf, &bufsize); 1640 4 if (count < 0) 1641 1 RETPUSHUNDEF; 1642 #ifdef EPOC 1643 /* Bogus return without padding */ 1644 bufsize = sizeof (struct sockaddr_in); 1645 #endif 1646 3 SvCUR_set(bufsv, count); 1647 3 *SvEND(bufsv) = '\0'; 1648 3 (void)SvPOK_only(bufsv); 1649 3 if (fp_utf8) 1650 ###### SvUTF8_on(bufsv); 1651 3 SvSETMAGIC(bufsv); 1652 /* This should not be marked tainted if the fp is marked clean */ 1653 3 if (!(IoFLAGS(io) & IOf_UNTAINT)) 1654 3 SvTAINTED_on(bufsv); 1655 3 SP = ORIGMARK; 1656 3 sv_setpvn(TARG, namebuf, bufsize); 1657 3 PUSHs(TARG); 1658 3 RETURN; 1659 } 1660 #else 1661 if (PL_op->op_type == OP_RECV) 1662 DIE(aTHX_ PL_no_sock_func, "recv"); 1663 #endif 1664 12949 if (DO_UTF8(bufsv)) { 1665 /* offset adjust in characters not bytes */ 1666 1047 blen = sv_len_utf8(bufsv); 1667 } 1668 12949 if (offset < 0) { 1669 642 if (-offset > (int)blen) 1670 1 DIE(aTHX_ "Offset outside string"); 1671 641 offset += blen; 1672 } 1673 12948 if (DO_UTF8(bufsv)) { 1674 /* convert offset-as-chars to offset-as-bytes */ 1675 1047 if (offset >= (int)blen) 1676 131 offset += SvCUR(bufsv) - blen; 1677 else 1678 916 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; 1679 } 1680 more_bytes: 1681 13762 bufsize = SvCUR(bufsv); 1682 /* Allocating length + offset + 1 isn't perfect in the case of reading 1683 bytes from a byte file handle into a UTF8 buffer, but it won't harm us 1684 unduly. 1685 (should be 2 * length + offset + 1, or possibly something longer if 1686 PL_encoding is true) */ 1687 13762 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); 1688 13762 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ 1689 162 Zero(buffer+bufsize, offset-bufsize, char); 1690 } 1691 13762 buffer = buffer + offset; 1692 13762 if (!buffer_utf8) { 1693 13506 read_target = bufsv; 1694 } else { 1695 /* Best to read the bytes into a new SV, upgrade that to UTF8, then 1696 concatenate it to the current buffer. */ 1697 1698 /* Truncate the existing buffer to the start of where we will be 1699 reading to: */ 1700 256 SvCUR_set(bufsv, offset); 1701 1702 256 read_target = sv_newmortal(); 1703 256 SvUPGRADE(read_target, SVt_PV); 1704 256 buffer = SvGROW(read_target, (STRLEN)(length + 1)); 1705 } 1706 1707 13762 if (PL_op->op_type == OP_SYSREAD) { 1708 #ifdef PERL_SOCK_SYSREAD_IS_RECV 1709 if (IoTYPE(io) == IoTYPE_SOCKET) { 1710 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)), 1711 buffer, length, 0); 1712 } 1713 else 1714 #endif 1715 { 1716 414 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)), 1717 buffer, length); 1718 } 1719 } 1720 else 1721 #ifdef HAS_SOCKET__bad_code_maybe 1722 if (IoTYPE(io) == IoTYPE_SOCKET) { 1723 char namebuf[MAXPATHLEN]; 1724 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS) 1725 bufsize = sizeof (struct sockaddr_in); 1726 #else 1727 bufsize = sizeof namebuf; 1728 #endif 1729 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0, 1730 (struct sockaddr *)namebuf, &bufsize); 1731 } 1732 else 1733 #endif 1734 { 1735 13348 count = PerlIO_read(IoIFP(io), buffer, length); 1736 /* PerlIO_read() - like fread() returns 0 on both error and EOF */ 1737 13348 if (count == 0 && PerlIO_error(IoIFP(io))) 1738 ###### count = -1; 1739 } 1740 13762 if (count < 0) { 1741 14 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO)) 1742 1 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY); 1743 1 goto say_undef; 1744 } 1745 13748 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); 1746 13748 *SvEND(read_target) = '\0'; 1747 13748 (void)SvPOK_only(read_target); 1748 13748 if (fp_utf8 && !IN_BYTES) { 1749 /* Look at utf8 we got back and count the characters */ 1750 1605 const char *bend = buffer + count; 1751 3165 while (buffer < bend) { 1752 1957 if (charstart) { 1753 1560 skip = UTF8SKIP(buffer); 1754 1560 charskip = 0; 1755 } 1756 1957 if (buffer - charskip + skip > bend) { 1757 /* partial character - try for rest of it */ 1758 397 length = skip - (bend-buffer); 1759 397 offset = bend - SvPVX_const(bufsv); 1760 397 charstart = FALSE; 1761 397 charskip += count; 1762 397 goto more_bytes; 1763 } 1764 else { 1765 1560 got++; 1766 1560 buffer += skip; 1767 1560 charstart = TRUE; 1768 1560 charskip = 0; 1769 } 1770 } 1771 /* If we have not 'got' the number of _characters_ we 'wanted' get some more 1772 provided amount read (count) was what was requested (length) 1773 */ 1774 1208 if (got < wanted && count == length) { 1775 417 length = wanted - got; 1776 417 offset = bend - SvPVX_const(bufsv); 1777 417 goto more_bytes; 1778 } 1779 /* return value is character count */ 1780 791 count = got; 1781 791 SvUTF8_on(bufsv); 1782 } 1783 12143 else if (buffer_utf8) { 1784 /* Let svcatsv upgrade the bytes we read in to utf8. 1785 The buffer is a mortal so will be freed soon. */ 1786 256 sv_catsv_nomg(bufsv, read_target); 1787 } 1788 12934 SvSETMAGIC(bufsv); 1789 /* This should not be marked tainted if the fp is marked clean */ 1790 12934 if (!(IoFLAGS(io) & IOf_UNTAINT)) 1791 12934 SvTAINTED_on(bufsv); 1792 12934 SP = ORIGMARK; 1793 12934 PUSHi(count); 1794 12934 RETURN; 1795 1796 say_undef: 1797 23 SP = ORIGMARK; 1798 23 RETPUSHUNDEF; 1799 } 1800 1801 PP(pp_syswrite) 1802 488 { 1803 488 dVAR; dSP; 1804 488 const int items = (SP - PL_stack_base) - TOPMARK; 1805 488 if (items == 2) { 1806 252 SV *sv; 1807 252 EXTEND(SP, 1); 1808 252 sv = sv_2mortal(newSViv(sv_len(*SP))); 1809 252 PUSHs(sv); 1810 252 PUTBACK; 1811 } 1812 488 return pp_send(); 1813 } 1814 1815 PP(pp_send) 1816 497 { 1817 497 dVAR; dSP; dMARK; dORIGMARK; dTARGET; 1818 497 GV *gv; 1819 497 IO *io; 1820 497 SV *bufsv; 1821 497 const char *buffer; 1822 497 Size_t length; 1823 497 SSize_t retval; 1824 497 STRLEN blen; 1825 497 MAGIC *mg; 1826 1827 497 gv = (GV*)*++MARK; 1828 497 if (PL_op->op_type == OP_SYSWRITE 1829 && gv && (io = GvIO(gv)) 1830 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 1831 { 1832 167 SV *sv; 1833 1834 167 PUSHMARK(MARK-1); 1835 167 *MARK = SvTIED_obj((SV*)io, mg); 1836 167 ENTER; 1837 167 call_method("WRITE", G_SCALAR); 1838 167 LEAVE; 1839 167 SPAGAIN; 1840 167 sv = POPs; 1841 167 SP = ORIGMARK; 1842 167 PUSHs(sv); 1843 167 RETURN; 1844 } 1845 330 if (!gv) 1846 ###### goto say_undef; 1847 330 bufsv = *++MARK; 1848 #if Size_t_size > IVSIZE 1849 length = (Size_t)SvNVx(*++MARK); 1850 #else 1851 330 length = (Size_t)SvIVx(*++MARK); 1852 #endif 1853 330 if ((SSize_t)length < 0) 1854 1 DIE(aTHX_ "Negative length"); 1855 329 SETERRNO(0,0); 1856 329 io = GvIO(gv); 1857 329 if (!io || !IoIFP(io)) { 1858 9 retval = -1; 1859 9 if (ckWARN(WARN_CLOSED)) 1860 4 report_evil_fh(gv, io, PL_op->op_type); 1861 9 SETERRNO(EBADF,RMS_IFI); 1862 9 goto say_undef; 1863 } 1864 1865 320 if (PerlIO_isutf8(IoIFP(io))) { 1866 8 if (!SvUTF8(bufsv)) { 1867 3 bufsv = sv_2mortal(newSVsv(bufsv)); 1868 3 buffer = sv_2pvutf8(bufsv, &blen); 1869 } else 1870 5 buffer = SvPV_const(bufsv, blen); 1871 } 1872 else { 1873 312 if (DO_UTF8(bufsv)) { 1874 /* Not modifying source SV, so making a temporary copy. */ 1875 ###### bufsv = sv_2mortal(newSVsv(bufsv)); 1876 ###### sv_utf8_downgrade(bufsv, FALSE); 1877 } 1878 312 buffer = SvPV_const(bufsv, blen); 1879 } 1880 1881 320 if (PL_op->op_type == OP_SYSWRITE) { 1882 315 IV offset; 1883 315 if (DO_UTF8(bufsv)) { 1884 /* length and offset are in chars */ 1885 8 blen = sv_len_utf8(bufsv); 1886 } 1887 315 if (MARK < SP) { 1888 205 offset = SvIVx(*++MARK); 1889 205 if (offset < 0) { 1890 2 if (-offset > (IV)blen) 1891 1 DIE(aTHX_ "Offset outside string"); 1892 1 offset += blen; 1893 203 } else if (offset >= (IV)blen && blen > 0) 1894 1 DIE(aTHX_ "Offset outside string"); 1895 } else 1896 110 offset = 0; 1897 313 if (length > blen - offset) 1898 2 length = blen - offset; 1899 313 if (DO_UTF8(bufsv)) { 1900 8 buffer = (const char*)utf8_hop((const U8 *)buffer, offset); 1901 8 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; 1902 } 1903 else { 1904 305 buffer = buffer+offset; 1905 } 1906 #ifdef PERL_SOCK_SYSWRITE_IS_SEND 1907 if (IoTYPE(io) == IoTYPE_SOCKET) { 1908 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), 1909 buffer, length, 0); 1910 } 1911 else 1912 #endif 1913 { 1914 /* See the note at doio.c:do_print about filesize limits. --jhi */ 1915 313 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)), 1916 buffer, length); 1917 } 1918 } 1919 #ifdef HAS_SOCKET 1920 5 else if (SP > MARK) { 1921 2 STRLEN mlen; 1922 2 char * const sockbuf = SvPVx(*++MARK, mlen); 1923 /* length is really flags */ 1924 2 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, 1925 length, (struct sockaddr *)sockbuf, mlen); 1926 } 1927 else 1928 /* length is really flags */ 1929 3 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length); 1930 #else 1931 else 1932 DIE(aTHX_ PL_no_sock_func, "send"); 1933 #endif 1934 318 if (retval < 0) 1935 1 goto say_undef; 1936 317 SP = ORIGMARK; 1937 317 if (DO_UTF8(bufsv)) 1938 8 retval = utf8_length((U8*)buffer, (U8*)buffer + retval); 1939 #if Size_t_size > IVSIZE 1940 PUSHn(retval); 1941 #else 1942 317 PUSHi(retval); 1943 #endif 1944 317 RETURN; 1945 1946 say_undef: 1947 10 SP = ORIGMARK; 1948 10 RETPUSHUNDEF; 1949 } 1950 1951 PP(pp_recv) 1952 4 { 1953 4 return pp_sysread(); 1954 } 1955 1956 PP(pp_eof) 1957 1535 { 1958 1535 dVAR; dSP; 1959 1535 GV *gv; 1960 1535 IO *io; 1961 1535 MAGIC *mg; 1962 1963 1535 if (MAXARG == 0) { 1964 812 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ 1965 9 IO *io; 1966 9 gv = PL_last_in_gv = GvEGV(PL_argvgv); 1967 9 io = GvIO(gv); 1968 9 if (io && !IoIFP(io)) { 1969 3 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { 1970 2 IoLINES(io) = 0; 1971 2 IoFLAGS(io) &= ~IOf_START; 1972 2 do_open(gv, (char *)"-", 1, FALSE, O_RDONLY, 0, Nullfp); 1973 2 sv_setpvn(GvSV(gv), "-", 1); 1974 2 SvSETMAGIC(GvSV(gv)); 1975 } 1976 1 else if (!nextargv(gv)) 1977 ###### RETPUSHYES; 1978 } 1979 } 1980 else 1981 803 gv = PL_last_in_gv; /* eof */ 1982 } 1983 else 1984 723 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */ 1985 1986 1535 if (gv && (io = GvIO(gv)) 1987 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 1988 { 1989 5 PUSHMARK(SP); 1990 5 XPUSHs(SvTIED_obj((SV*)io, mg)); 1991 5 PUTBACK; 1992 5 ENTER; 1993 5 call_method("EOF", G_SCALAR); 1994 5 LEAVE; 1995 5 SPAGAIN; 1996 5 RETURN; 1997 } 1998 1999 1530 PUSHs(boolSV(!gv || do_eof(gv))); 2000 1530 RETURN; 2001 } 2002 2003 PP(pp_tell) 2004 5579 { 2005 5579 dVAR; dSP; dTARGET; 2006 5579 GV *gv; 2007 5579 IO *io; 2008 5579 MAGIC *mg; 2009 2010 5579 if (MAXARG == 0) 2011 9 gv = PL_last_in_gv; 2012 else 2013 5570 gv = PL_last_in_gv = (GV*)POPs; 2014 2015 5579 if (gv && (io = GvIO(gv)) 2016 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 2017 { 2018 187 PUSHMARK(SP); 2019 187 XPUSHs(SvTIED_obj((SV*)io, mg)); 2020 187 PUTBACK; 2021 187 ENTER; 2022 187 call_method("TELL", G_SCALAR); 2023 1 LEAVE; 2024 1 SPAGAIN; 2025 1 RETURN; 2026 } 2027 2028 #if LSEEKSIZE > IVSIZE 2029 5392 PUSHn( do_tell(gv) ); 2030 #else 2031 PUSHi( do_tell(gv) ); 2032 #endif 2033 5392 RETURN; 2034 } 2035 2036 PP(pp_seek) 2037 29042 { 2038 29042 return pp_sysseek(); 2039 } 2040 2041 PP(pp_sysseek) 2042 29085 { 2043 29085 dVAR; dSP; 2044 29085 GV *gv; 2045 29085 IO *io; 2046 29085 const int whence = POPi; 2047 #if LSEEKSIZE > IVSIZE 2048 29085 Off_t offset = (Off_t)SvNVx(POPs); 2049 #else 2050 Off_t offset = (Off_t)SvIVx(POPs); 2051 #endif 2052 29085 MAGIC *mg; 2053 2054 29085 gv = PL_last_in_gv = (GV*)POPs; 2055 2056 29085 if (gv && (io = GvIO(gv)) 2057 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 2058 { 2059 1 PUSHMARK(SP); 2060 1 XPUSHs(SvTIED_obj((SV*)io, mg)); 2061 #if LSEEKSIZE > IVSIZE 2062 1 XPUSHs(sv_2mortal(newSVnv((NV) offset))); 2063 #else 2064 XPUSHs(sv_2mortal(newSViv(offset))); 2065 #endif 2066 1 XPUSHs(sv_2mortal(newSViv(whence))); 2067 1 PUTBACK; 2068 1 ENTER; 2069 1 call_method("SEEK", G_SCALAR); 2070 1 LEAVE; 2071 1 SPAGAIN; 2072 1 RETURN; 2073 } 2074 2075 29084 if (PL_op->op_type == OP_SEEK) 2076 29041 PUSHs(boolSV(do_seek(gv, offset, whence))); 2077 else { 2078 43 Off_t sought = do_sysseek(gv, offset, whence); 2079 43 if (sought < 0) 2080 6 PUSHs(&PL_sv_undef); 2081 else { 2082 37 SV* sv = sought ? 2083 #if LSEEKSIZE > IVSIZE 2084 newSVnv((NV)sought) 2085 #else 2086 newSViv(sought) 2087 #endif 2088 37 : newSVpvn(zero_but_true, ZBTLEN); 2089 37 PUSHs(sv_2mortal(sv)); 2090 } 2091 } 2092 29084 RETURN; 2093 } 2094 2095 PP(pp_truncate) 2096 2242 { 2097 2242 dSP; 2098 /* There seems to be no consensus on the length type of truncate() 2099 * and ftruncate(), both off_t and size_t have supporters. In 2100 * general one would think that when using large files, off_t is 2101 * at least as wide as size_t, so using an off_t should be okay. */ 2102 /* XXX Configure probe for the length type of *truncate() needed XXX */ 2103 2242 Off_t len; 2104 2105 #if Off_t_size > IVSIZE 2106 2242 len = (Off_t)POPn; 2107 #else 2108 len = (Off_t)POPi; 2109 #endif 2110 /* Checking for length < 0 is problematic as the type might or 2111 * might not be signed: if it is not, clever compilers will moan. */ 2112 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ 2113 2242 SETERRNO(0,0); 2114 { 2115 2242 int result = 1; 2116 2242 GV *tmpgv; 2117 2242 IO *io; 2118 2119 2242 if (PL_op->op_flags & OPf_SPECIAL) { 2120 3 tmpgv = gv_fetchsv(POPs, FALSE, SVt_PVIO); 2121 2122 do_ftruncate_gv: 2123 2238 if (!GvIO(tmpgv)) 2124 ###### result = 0; 2125 else { 2126 2238 PerlIO *fp; 2127 2238 io = GvIOp(tmpgv); 2128 do_ftruncate_io: 2129 2239 TAINT_PROPER("truncate"); 2130 2239 if (!(fp = IoIFP(io))) { 2131 ###### result = 0; 2132 } 2133 else { 2134 2239 PerlIO_flush(fp); 2135 #ifdef HAS_TRUNCATE 2136 2239 if (ftruncate(PerlIO_fileno(fp), len) < 0) 2137 #else 2138 if (my_chsize(PerlIO_fileno(fp), len) < 0) 2139 #endif 2140 ###### result = 0; 2141 } 2142 } 2143 } 2144 else { 2145 2239 SV *sv = POPs; 2146 2239 const char *name; 2147 2148 2239 if (SvTYPE(sv) == SVt_PVGV) { 2149 ###### tmpgv = (GV*)sv; /* *main::FRED for example */ 2150 ###### goto do_ftruncate_gv; 2151 } 2152 2239 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { 2153 2235 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ 2154 2235 goto do_ftruncate_gv; 2155 } 2156 4 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 2157 1 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */ 2158 1 goto do_ftruncate_io; 2159 } 2160 2161 3 name = SvPV_nolen_const(sv); 2162 3 TAINT_PROPER("truncate"); 2163 #ifdef HAS_TRUNCATE 2164 2 if (truncate(name, len) < 0) 2165 ###### result = 0; 2166 #else 2167 { 2168 int tmpfd; 2169 2170 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0) 2171 result = 0; 2172 else { 2173 if (my_chsize(tmpfd, len) < 0) 2174 result = 0; 2175 PerlLIO_close(tmpfd); 2176 } 2177 } 2178 #endif 2179 } 2180 2181 2241 if (result) 2182 2241 RETPUSHYES; 2183 ###### if (!errno) 2184 ###### SETERRNO(EBADF,RMS_IFI); 2185 ###### RETPUSHUNDEF; 2186 } 2187 } 2188 2189 PP(pp_fcntl) 2190 71 { 2191 71 return pp_ioctl(); 2192 } 2193 2194 PP(pp_ioctl) 2195 72 { 2196 72 dSP; dTARGET; 2197 72 SV *argsv = POPs; 2198 72 const unsigned int func = POPu; 2199 72 const int optype = PL_op->op_type; 2200 72 char *s; 2201 72 IV retval; 2202 72 GV *gv = (GV*)POPs; 2203 72 IO *io = gv ? GvIOn(gv) : 0; 2204 2205 72 if (!io || !argsv || !IoIFP(io)) { 2206 ###### if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 2207 ###### report_evil_fh(gv, io, PL_op->op_type); 2208 ###### SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ 2209 ###### RETPUSHUNDEF; 2210 } 2211 2212 72 if (SvPOK(argsv) || !SvNIOK(argsv)) { 2213 2 STRLEN len; 2214 2 STRLEN need; 2215 2 s = SvPV_force(argsv, len); 2216 2 need = IOCPARM_LEN(func); 2217 2 if (len < need) { 2218 ###### s = Sv_Grow(argsv, need + 1); 2219 ###### SvCUR_set(argsv, need); 2220 } 2221 2222 2 s[SvCUR(argsv)] = 17; /* a little sanity check here */ 2223 } 2224 else { 2225 70 retval = SvIV(argsv); 2226 70 s = INT2PTR(char*,retval); /* ouch */ 2227 } 2228 2229 72 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl"); 2230 2231 70 if (optype == OP_IOCTL) 2232 #ifdef HAS_IOCTL 2233 ###### retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s); 2234 #else 2235 DIE(aTHX_ "ioctl is not implemented"); 2236 #endif 2237 else 2238 #ifndef HAS_FCNTL 2239 DIE(aTHX_ "fcntl is not implemented"); 2240 #else 2241 #if defined(OS2) && defined(__EMX__) 2242 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); 2243 #else 2244 70 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); 2245 #endif 2246 #endif 2247 2248 #if defined(HAS_IOCTL) || defined(HAS_FCNTL) 2249 70 if (SvPOK(argsv)) { 2250 ###### if (s[SvCUR(argsv)] != 17) 2251 ###### DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", 2252 OP_NAME(PL_op)); 2253 ###### s[SvCUR(argsv)] = 0; /* put our null back */ 2254 ###### SvSETMAGIC(argsv); /* Assume it has changed */ 2255 } 2256 2257 70 if (retval == -1) 2258 ###### RETPUSHUNDEF; 2259 70 if (retval != 0) { 2260 35 PUSHi(retval); 2261 } 2262 else { 2263 35 PUSHp(zero_but_true, ZBTLEN); 2264 } 2265 #endif 2266 70 RETURN; 2267 } 2268 2269 PP(pp_flock) 2270 14 { 2271 #ifdef FLOCK 2272 14 dSP; dTARGET; 2273 14 I32 value; 2274 14 int argtype; 2275 14 GV *gv; 2276 14 IO *io = NULL; 2277 14 PerlIO *fp; 2278 2279 14 argtype = POPi; 2280 14 if (MAXARG == 0) 2281 ###### gv = PL_last_in_gv; 2282 else 2283 14 gv = (GV*)POPs; 2284 14 if (gv && (io = GvIO(gv))) 2285 11 fp = IoIFP(io); 2286 else { 2287 3 fp = Nullfp; 2288 3 io = NULL; 2289 } 2290 14 if (fp) { 2291 5 (void)PerlIO_flush(fp); 2292 5 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); 2293 } 2294 else { 2295 9 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 2296 4 report_evil_fh(gv, io, PL_op->op_type); 2297 9 value = 0; 2298 9 SETERRNO(EBADF,RMS_IFI); 2299 } 2300 14 PUSHi(value); 2301 14 RETURN; 2302 #else 2303 DIE(aTHX_ PL_no_func, "flock()"); 2304 #endif 2305 } 2306 2307 /* Sockets. */ 2308 2309 PP(pp_socket) 2310 50 { 2311 #ifdef HAS_SOCKET 2312 50 dSP; 2313 50 GV *gv; 2314 50 register IO *io; 2315 50 int protocol = POPi; 2316 50 int type = POPi; 2317 50 int domain = POPi; 2318 50 int fd; 2319 2320 50 gv = (GV*)POPs; 2321 50 io = gv ? GvIOn(gv) : NULL; 2322 2323 50 if (!gv || !io) { 2324 ###### if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 2325 ###### report_evil_fh(gv, io, PL_op->op_type); 2326 ###### if (IoIFP(io)) 2327 ###### do_close(gv, FALSE); 2328 ###### SETERRNO(EBADF,LIB_INVARG); 2329 ###### RETPUSHUNDEF; 2330 } 2331 2332 50 if (IoIFP(io)) 2333 3 do_close(gv, FALSE); 2334 2335 50 TAINT_PROPER("socket"); 2336 50 fd = PerlSock_socket(domain, type, protocol); 2337 50 if (fd < 0) 2338 1 RETPUSHUNDEF; 2339 49 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ 2340 49 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); 2341 49 IoTYPE(io) = IoTYPE_SOCKET; 2342 49 if (!IoIFP(io) || !IoOFP(io)) { 2343 ###### if (IoIFP(io)) PerlIO_close(IoIFP(io)); 2344 ###### if (IoOFP(io)) PerlIO_close(IoOFP(io)); 2345 ###### if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); 2346 ###### RETPUSHUNDEF; 2347 } 2348 #if defined(HAS_FCNTL) && defined(F_SETFD) 2349 49 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ 2350 #endif 2351 2352 #ifdef EPOC 2353 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */ 2354 #endif 2355 2356 49 RETPUSHYES; 2357 #else 2358 DIE(aTHX_ PL_no_sock_func, "socket"); 2359 #endif 2360 } 2361 2362 PP(pp_sockpair) 2363 4 { 2364 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) 2365 4 dSP; 2366 4 GV *gv1; 2367 4 GV *gv2; 2368 4 register IO *io1; 2369 4 register IO *io2; 2370 4 int protocol = POPi; 2371 4 int type = POPi; 2372 4 int domain = POPi; 2373 4 int fd[2]; 2374 2375 4 gv2 = (GV*)POPs; 2376 4 gv1 = (GV*)POPs; 2377 4 io1 = gv1 ? GvIOn(gv1) : NULL; 2378 4 io2 = gv2 ? GvIOn(gv2) : NULL; 2379 4 if (!gv1 || !gv2 || !io1 || !io2) { 2380 ###### if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) { 2381 ###### if (!gv1 || !io1) 2382 ###### report_evil_fh(gv1, io1, PL_op->op_type); 2383 ###### if (!gv2 || !io2) 2384 ###### report_evil_fh(gv1, io2, PL_op->op_type); 2385 } 2386 ###### if (IoIFP(io1)) 2387 ###### do_close(gv1, FALSE); 2388 ###### if (IoIFP(io2)) 2389 ###### do_close(gv2, FALSE); 2390 ###### RETPUSHUNDEF; 2391 } 2392 2393 4 if (IoIFP(io1)) 2394 ###### do_close(gv1, FALSE); 2395 4 if (IoIFP(io2)) 2396 ###### do_close(gv2, FALSE); 2397 2398 4 TAINT_PROPER("socketpair"); 2399 4 if (PerlSock_socketpair(domain, type, protocol, fd) < 0) 2400 2 RETPUSHUNDEF; 2401 2 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE); 2402 2 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE); 2403 2 IoTYPE(io1) = IoTYPE_SOCKET; 2404 2 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE); 2405 2 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE); 2406 2 IoTYPE(io2) = IoTYPE_SOCKET; 2407 2 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { 2408 ###### if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); 2409 ###### if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); 2410 ###### if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]); 2411 ###### if (IoIFP(io2)) PerlIO_close(IoIFP(io2)); 2412 ###### if (IoOFP(io2)) PerlIO_close(IoOFP(io2)); 2413 ###### if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); 2414 ###### RETPUSHUNDEF; 2415 } 2416 #if defined(HAS_FCNTL) && defined(F_SETFD) 2417 2 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ 2418 2 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ 2419 #endif 2420 2421 2 RETPUSHYES; 2422 #else 2423 DIE(aTHX_ PL_no_sock_func, "socketpair"); 2424 #endif 2425 } 2426 2427 PP(pp_bind) 2428 14 { 2429 #ifdef HAS_SOCKET 2430 14 dSP; 2431 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */ 2432 extern void GETPRIVMODE(); 2433 extern void GETUSERMODE(); 2434 #endif 2435 14 SV *addrsv = POPs; 2436 /* OK, so on what platform does bind modify addr? */ 2437 14 const char *addr; 2438 14 GV *gv = (GV*)POPs; 2439 14 register IO *io = GvIOn(gv); 2440 14 STRLEN len; 2441 14 int bind_ok = 0; 2442 #ifdef MPE 2443 int mpeprivmode = 0; 2444 #endif 2445 2446 14 if (!io || !IoIFP(io)) 2447 4 goto nuts; 2448 2449 10 addr = SvPV_const(addrsv, len); 2450 10 TAINT_PROPER("bind"); 2451 #ifdef MPE /* Deal with MPE bind() peculiarities */ 2452 if (((struct sockaddr *)addr)->sa_family == AF_INET) { 2453 /* The address *MUST* stupidly be zero. */ 2454 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY; 2455 /* PRIV mode is required to bind() to ports < 1024. */ 2456 if (((struct sockaddr_in *)addr)->sin_port < 1024 && 2457 ((struct sockaddr_in *)addr)->sin_port > 0) { 2458 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */ 2459 mpeprivmode = 1; 2460 } 2461 } 2462 #endif /* MPE */ 2463 10 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), 2464 (struct sockaddr *)addr, len) >= 0) 2465 10 bind_ok = 1; 2466 2467 #ifdef MPE /* Switch back to USER mode */ 2468 if (mpeprivmode) 2469 GETUSERMODE(); 2470 #endif /* MPE */ 2471 2472 10 if (bind_ok) 2473 10 RETPUSHYES; 2474 else 2475 ###### RETPUSHUNDEF; 2476 2477 nuts: 2478 4 if (ckWARN(WARN_CLOSED)) 2479 2 report_evil_fh(gv, io, PL_op->op_type); 2480 4 SETERRNO(EBADF,SS_IVCHAN); 2481 4 RETPUSHUNDEF; 2482 #else 2483 DIE(aTHX_ PL_no_sock_func, "bind"); 2484 #endif 2485 } 2486 2487 PP(pp_connect) 2488 40 { 2489 #ifdef HAS_SOCKET 2490 40 dSP; 2491 40 SV *addrsv = POPs; 2492 40 const char *addr; 2493 40 GV *gv = (GV*)POPs; 2494 40 register IO *io = GvIOn(gv); 2495 40 STRLEN len; 2496 2497 40 if (!io || !IoIFP(io)) 2498 4 goto nuts; 2499 2500 36 addr = SvPV_const(addrsv, len); 2501 36 TAINT_PROPER("connect"); 2502 36 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) 2503 12 RETPUSHYES; 2504 else 2505 24 RETPUSHUNDEF; 2506 2507 nuts: 2508 4 if (ckWARN(WARN_CLOSED)) 2509 2 report_evil_fh(gv, io, PL_op->op_type); 2510 4 SETERRNO(EBADF,SS_IVCHAN); 2511 4 RETPUSHUNDEF; 2512 #else 2513 DIE(aTHX_ PL_no_sock_func, "connect"); 2514 #endif 2515 } 2516 2517 PP(pp_listen) 2518 11 { 2519 #ifdef HAS_SOCKET 2520 11 dSP; 2521 11 int backlog = POPi; 2522 11 GV *gv = (GV*)POPs; 2523 11 register IO *io = gv ? GvIOn(gv) : NULL; 2524 2525 11 if (!gv || !io || !IoIFP(io)) 2526 4 goto nuts; 2527 2528 7 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) 2529 7 RETPUSHYES; 2530 else 2531 ###### RETPUSHUNDEF; 2532 2533 nuts: 2534 4 if (ckWARN(WARN_CLOSED)) 2535 2 report_evil_fh(gv, io, PL_op->op_type); 2536 4 SETERRNO(EBADF,SS_IVCHAN); 2537 4 RETPUSHUNDEF; 2538 #else 2539 DIE(aTHX_ PL_no_sock_func, "listen"); 2540 #endif 2541 } 2542 2543 PP(pp_accept) 2544 13 { 2545 #ifdef HAS_SOCKET 2546 13 dSP; dTARGET; 2547 13 GV *ngv; 2548 13 GV *ggv; 2549 13 register IO *nstio; 2550 13 register IO *gstio; 2551 13 char namebuf[MAXPATHLEN]; 2552 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) 2553 Sock_size_t len = sizeof (struct sockaddr_in); 2554 #else 2555 13 Sock_size_t len = sizeof namebuf; 2556 #endif 2557 13 int fd; 2558 2559 13 ggv = (GV*)POPs; 2560 13 ngv = (GV*)POPs; 2561 2562 13 if (!ngv) 2563 ###### goto badexit; 2564 13 if (!ggv) 2565 ###### goto nuts; 2566 2567 13 gstio = GvIO(ggv); 2568 13 if (!gstio || !IoIFP(gstio)) 2569 3 goto nuts; 2570 2571 9 nstio = GvIOn(ngv); 2572 9 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); 2573 9 if (fd < 0) 2574 ###### goto badexit; 2575 9 if (IoIFP(nstio)) 2576 ###### do_close(ngv, FALSE); 2577 9 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); 2578 9 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); 2579 9 IoTYPE(nstio) = IoTYPE_SOCKET; 2580 9 if (!IoIFP(nstio) || !IoOFP(nstio)) { 2581 ###### if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); 2582 ###### if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio)); 2583 ###### if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); 2584 ###### goto badexit; 2585 } 2586 #if defined(HAS_FCNTL) && defined(F_SETFD) 2587 9 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ 2588 #endif 2589 2590 #ifdef EPOC 2591 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */ 2592 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */ 2593 #endif 2594 #ifdef __SCO_VERSION__ 2595 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ 2596 #endif 2597 2598 9 PUSHp(namebuf, len); 2599 9 RETURN; 2600 2601 nuts: 2602 4 if (ckWARN(WARN_CLOSED)) 2603 2 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); 2604 4 SETERRNO(EBADF,SS_IVCHAN); 2605 2606 badexit: 2607 4 RETPUSHUNDEF; 2608 2609 #else 2610 DIE(aTHX_ PL_no_sock_func, "accept"); 2611 #endif 2612 } 2613 2614 PP(pp_shutdown) 2615 6 { 2616 #ifdef HAS_SOCKET 2617 6 dSP; dTARGET; 2618 6 int how = POPi; 2619 6 GV *gv = (GV*)POPs; 2620 6 register IO *io = GvIOn(gv); 2621 2622 6 if (!io || !IoIFP(io)) 2623 4 goto nuts; 2624 2625 2 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); 2626 2 RETURN; 2627 2628 nuts: 2629 4 if (ckWARN(WARN_CLOSED)) 2630 2 report_evil_fh(gv, io, PL_op->op_type); 2631 4 SETERRNO(EBADF,SS_IVCHAN); 2632 4 RETPUSHUNDEF; 2633 #else 2634 DIE(aTHX_ PL_no_sock_func, "shutdown"); 2635 #endif 2636 } 2637 2638 PP(pp_gsockopt) 2639 4 { 2640 #ifdef HAS_SOCKET 2641 4 return pp_ssockopt(); 2642 #else 2643 DIE(aTHX_ PL_no_sock_func, "getsockopt"); 2644 #endif 2645 } 2646 2647 PP(pp_ssockopt) 2648 8 { 2649 #ifdef HAS_SOCKET 2650 8 dSP; 2651 8 int optype = PL_op->op_type; 2652 8 SV *sv; 2653 8 int fd; 2654 8 unsigned int optname; 2655 8 unsigned int lvl; 2656 8 GV *gv; 2657 8 register IO *io; 2658 8 Sock_size_t len; 2659 2660 8 if (optype == OP_GSOCKOPT) 2661 4 sv = sv_2mortal(NEWSV(22, 257)); 2662 else 2663 4 sv = POPs; 2664 8 optname = (unsigned int) POPi; 2665 8 lvl = (unsigned int) POPi; 2666 2667 8 gv = (GV*)POPs; 2668 8 io = GvIOn(gv); 2669 8 if (!io || !IoIFP(io)) 2670 8 goto nuts; 2671 2672 ###### fd = PerlIO_fileno(IoIFP(io)); 2673 ###### switch (optype) { 2674 case OP_GSOCKOPT: 2675 ###### SvGROW(sv, 257); 2676 ###### (void)SvPOK_only(sv); 2677 ###### SvCUR_set(sv,256); 2678 ###### *SvEND(sv) ='\0'; 2679 ###### len = SvCUR(sv); 2680 ###### if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0) 2681 ###### goto nuts2; 2682 ###### SvCUR_set(sv, len); 2683 ###### *SvEND(sv) ='\0'; 2684 ###### PUSHs(sv); 2685 ###### break; 2686 case OP_SSOCKOPT: { 2687 ###### const char *buf; 2688 ###### int aint; 2689 ###### if (SvPOKp(sv)) { 2690 ###### STRLEN l; 2691 ###### buf = SvPV_const(sv, l); 2692 ###### len = l; 2693 } 2694 else { 2695 ###### aint = (int)SvIV(sv); 2696 ###### buf = (const char*)&aint; 2697 ###### len = sizeof(int); 2698 } 2699 ###### if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) 2700 ###### goto nuts2; 2701 ###### PUSHs(&PL_sv_yes); 2702 } 2703 break; 2704 } 2705 ###### RETURN; 2706 2707 nuts: 2708 8 if (ckWARN(WARN_CLOSED)) 2709 4 report_evil_fh(gv, io, optype); 2710 8 SETERRNO(EBADF,SS_IVCHAN); 2711 nuts2: 2712 8 RETPUSHUNDEF; 2713 2714 #else 2715 DIE(aTHX_ PL_no_sock_func, "setsockopt"); 2716 #endif 2717 } 2718 2719 PP(pp_getsockname) 2720 14 { 2721 #ifdef HAS_SOCKET 2722 14 return pp_getpeername(); 2723 #else 2724 DIE(aTHX_ PL_no_sock_func, "getsockname"); 2725 #endif 2726 } 2727 2728 PP(pp_getpeername) 2729 42 { 2730 #ifdef HAS_SOCKET 2731 42 dSP; 2732 42 int optype = PL_op->op_type; 2733 42 SV *sv; 2734 42 int fd; 2735 42 GV *gv = (GV*)POPs; 2736 42 register IO *io = GvIOn(gv); 2737 42 Sock_size_t len; 2738 2739 42 if (!io || !IoIFP(io)) 2740 8 goto nuts; 2741 2742 34 sv = sv_2mortal(NEWSV(22, 257)); 2743 34 (void)SvPOK_only(sv); 2744 34 len = 256; 2745 34 SvCUR_set(sv, len); 2746 34 *SvEND(sv) ='\0'; 2747 34 fd = PerlIO_fileno(IoIFP(io)); 2748 34 switch (optype) { 2749 case OP_GETSOCKNAME: 2750 10 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) 2751 ###### goto nuts2; 2752 24 break; 2753 case OP_GETPEERNAME: 2754 24 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) 2755 15 goto nuts2; 2756 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS) 2757 { 2758 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"; 2759 /* If the call succeeded, make sure we don't have a zeroed port/addr */ 2760 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && 2761 !memcmp((char *)SvPVX_const(sv) + sizeof(u_short), nowhere, 2762 sizeof(u_short) + sizeof(struct in_addr))) { 2763 goto nuts2; 2764 } 2765 } 2766 #endif 2767 19 break; 2768 } 2769 #ifdef BOGUS_GETNAME_RETURN 2770 /* Interactive Unix, getpeername() and getsockname() 2771 does not return valid namelen */ 2772 if (len == BOGUS_GETNAME_RETURN) 2773 len = sizeof(struct sockaddr); 2774 #endif 2775 19 SvCUR_set(sv, len); 2776 19 *SvEND(sv) ='\0'; 2777 19 PUSHs(sv); 2778 19 RETURN; 2779 2780 nuts: 2781 8 if (ckWARN(WARN_CLOSED)) 2782 4 report_evil_fh(gv, io, optype); 2783 8 SETERRNO(EBADF,SS_IVCHAN); 2784 nuts2: 2785 23 RETPUSHUNDEF; 2786 2787 #else 2788 DIE(aTHX_ PL_no_sock_func, "getpeername"); 2789 #endif 2790 } 2791 2792 /* Stat calls. */ 2793 2794 PP(pp_lstat) 2795 9689 { 2796 9689 return pp_stat(); 2797 } 2798 2799 PP(pp_stat) 2800 11125 { 2801 11125 dSP; 2802 11125 GV *gv; 2803 11125 I32 gimme; 2804 11125 I32 max = 13; 2805 2806 11125 if (PL_op->op_flags & OPf_REF) { 2807 17 gv = cGVOP_gv; 2808 17 if (PL_op->op_type == OP_LSTAT) { 2809 5 if (gv != PL_defgv) { 2810 2 if (ckWARN(WARN_IO)) 2811 1 Perl_warner(aTHX_ packWARN(WARN_IO), 2812 "lstat() on filehandle %s", GvENAME(gv)); 2813 3 } else if (PL_laststype != OP_LSTAT) 2814 2 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); 2815 } 2816 2817 do_fstat: 2818 57 if (gv != PL_defgv) { 2819 53 PL_laststype = OP_STAT; 2820 53 PL_statgv = gv; 2821 53 sv_setpvn(PL_statname, "", 0); 2822 53 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv)) 2823 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1); 2824 } 2825 57 if (PL_laststatval < 0) { 2826 7 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 2827 3 report_evil_fh(gv, GvIO(gv), PL_op->op_type); 2828 7 max = 0; 2829 } 2830 } 2831 else { 2832 11108 SV* sv = POPs; 2833 11108 if (SvTYPE(sv) == SVt_PVGV) { 2834 6 gv = (GV*)sv; 2835 6 goto do_fstat; 2836 } 2837 11102 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { 2838 36 gv = (GV*)SvRV(sv); 2839 36 if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO)) 2840 1 Perl_warner(aTHX_ packWARN(WARN_IO), 2841 "lstat() on filehandle %s", GvENAME(gv)); 2842 1 goto do_fstat; 2843 } 2844 11066 sv_setpv(PL_statname, SvPV_nolen_const(sv)); 2845 11066 PL_statgv = Nullgv; 2846 11066 PL_laststype = PL_op->op_type; 2847 11066 if (PL_op->op_type == OP_LSTAT) 2848 9682 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache); 2849 else 2850 1384 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); 2851 11066 if (PL_laststatval < 0) { 2852 211 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n')) 2853 3 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); 2854 211 max = 0; 2855 } 2856 } 2857 2858 11123 gimme = GIMME_V; 2859 11123 if (gimme != G_ARRAY) { 2860 82 if (gimme != G_VOID) 2861 1 XPUSHs(boolSV(max)); 2862 82 RETURN; 2863 } 2864 11041 if (max) { 2865 10842 EXTEND(SP, max); 2866 10842 EXTEND_MORTAL(max); 2867 10842 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev))); 2868 10842 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino))); 2869 10842 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode))); 2870 10842 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink))); 2871 #if Uid_t_size > IVSIZE 2872 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid))); 2873 #else 2874 # if Uid_t_sign <= 0 2875 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid))); 2876 # else 2877 10842 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid))); 2878 # endif 2879 #endif 2880 #if Gid_t_size > IVSIZE 2881 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid))); 2882 #else 2883 # if Gid_t_sign <= 0 2884 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid))); 2885 # else 2886 10842 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid))); 2887 # endif 2888 #endif 2889 #ifdef USE_STAT_RDEV 2890 10842 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev))); 2891 #else 2892 PUSHs(sv_2mortal(newSVpvn("", 0))); 2893 #endif 2894 #if Off_t_size > IVSIZE 2895 10842 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size))); 2896 #else 2897 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size))); 2898 #endif 2899 #ifdef BIG_TIME 2900 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime))); 2901 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime))); 2902 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime))); 2903 #else 2904 10842 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime))); 2905 10842 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime))); 2906 10842 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime))); 2907 #endif 2908 #ifdef USE_STAT_BLOCKS 2909 10842 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize))); 2910 10842 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks))); 2911 #else 2912 PUSHs(sv_2mortal(newSVpvn("", 0))); 2913 PUSHs(sv_2mortal(newSVpvn("", 0))); 2914 #endif 2915 } 2916 11041 RETURN; 2917 } 2918 2919 /* This macro is used by the stacked filetest operators : 2920 * if the previous filetest failed, short-circuit and pass its value. 2921 * Else, discard it from the stack and continue. --rgs 2922 */ 2923 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \ 2924 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \ 2925 else { (void)POPs; PUTBACK; } \ 2926 } 2927 2928 PP(pp_ftrread) 2929 1 { 2930 1 I32 result; 2931 1 dSP; 2932 1 STACKED_FTEST_CHECK; 2933 #if defined(HAS_ACCESS) && defined(R_OK) 2934 1 if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { 2935 ###### result = access(POPpx, R_OK); 2936 ###### if (result == 0) 2937 ###### RETPUSHYES; 2938 ###### if (result < 0) 2939 ###### RETPUSHUNDEF; 2940 ###### RETPUSHNO; 2941 } 2942 else 2943 1 result = my_stat(); 2944 #else 2945 result = my_stat(); 2946 #endif 2947 1 SPAGAIN; 2948 1 if (result < 0) 2949 1 RETPUSHUNDEF; 2950 ###### if (cando(S_IRUSR, 0, &PL_statcache)) 2951 ###### RETPUSHYES; 2952 ###### RETPUSHNO; 2953 } 2954 2955 PP(pp_ftrwrite) 2956 1 { 2957 1 I32 result; 2958 1 dSP; 2959 1 STACKED_FTEST_CHECK; 2960 #if defined(HAS_ACCESS) && defined(W_OK) 2961 1 if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { 2962 ###### result = access(POPpx, W_OK); 2963 ###### if (result == 0) 2964 ###### RETPUSHYES; 2965 ###### if (result < 0) 2966 ###### RETPUSHUNDEF; 2967 ###### RETPUSHNO; 2968 } 2969 else 2970 1 result = my_stat(); 2971 #else 2972 result = my_stat(); 2973 #endif 2974 1 SPAGAIN; 2975 1 if (result < 0) 2976 1 RETPUSHUNDEF; 2977 ###### if (cando(S_IWUSR, 0, &PL_statcache)) 2978 ###### RETPUSHYES; 2979 ###### RETPUSHNO; 2980 } 2981 2982 PP(pp_ftrexec) 2983 1 { 2984 1 I32 result; 2985 1 dSP; 2986 1 STACKED_FTEST_CHECK; 2987 #if defined(HAS_ACCESS) && defined(X_OK) 2988 1 if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { 2989 ###### result = access(POPpx, X_OK); 2990 ###### if (result == 0) 2991 ###### RETPUSHYES; 2992 ###### if (result < 0) 2993 ###### RETPUSHUNDEF; 2994 ###### RETPUSHNO; 2995 } 2996 else 2997 1 result = my_stat(); 2998 #else 2999 result = my_stat(); 3000 #endif 3001 1 SPAGAIN; 3002 1 if (result < 0) 3003 1 RETPUSHUNDEF; 3004 ###### if (cando(S_IXUSR, 0, &PL_statcache)) 3005 ###### RETPUSHYES; 3006 ###### RETPUSHNO; 3007 } 3008 3009 PP(pp_fteread) 3010 1618 { 3011 1618 I32 result; 3012 1618 dSP; 3013 1618 STACKED_FTEST_CHECK; 3014 #ifdef PERL_EFF_ACCESS_R_OK 3015 1618 if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { 3016 ###### result = PERL_EFF_ACCESS_R_OK(POPpx); 3017 ###### if (result == 0) 3018 ###### RETPUSHYES; 3019 ###### if (result < 0) 3020 ###### RETPUSHUNDEF; 3021 ###### RETPUSHNO; 3022 } 3023 else 3024 1618 result = my_stat(); 3025 #else 3026 result = my_stat(); 3027 #endif 3028 1618 SPAGAIN; 3029 1618 if (result < 0) 3030 27 RETPUSHUNDEF; 3031 1591 if (cando(S_IRUSR, 1, &PL_statcache)) 3032 1590 RETPUSHYES; 3033 1 RETPUSHNO; 3034 } 3035 3036 PP(pp_ftewrite) 3037 150 { 3038 150 I32 result; 3039 150 dSP; 3040 150 STACKED_FTEST_CHECK; 3041 #ifdef PERL_EFF_ACCESS_W_OK 3042 150 if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { 3043 ###### result = PERL_EFF_ACCESS_W_OK(POPpx); 3044 ###### if (result == 0) 3045 ###### RETPUSHYES; 3046 ###### if (result < 0) 3047 ###### RETPUSHUNDEF; 3048 ###### RETPUSHNO; 3049 } 3050 else 3051 150 result = my_stat(); 3052 #else 3053 result = my_stat(); 3054 #endif 3055 150 SPAGAIN; 3056 150 if (result < 0) 3057 53 RETPUSHUNDEF; 3058 97 if (cando(S_IWUSR, 1, &PL_statcache)) 3059 92 RETPUSHYES; 3060 5 RETPUSHNO; 3061 } 3062 3063 PP(pp_fteexec) 3064 3758 { 3065 3758 I32 result; 3066 3758 dSP; 3067 3758 STACKED_FTEST_CHECK; 3068 #ifdef PERL_EFF_ACCESS_X_OK 3069 3758 if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) { 3070 ###### result = PERL_EFF_ACCESS_X_OK(POPpx); 3071 ###### if (result == 0) 3072 ###### RETPUSHYES; 3073 ###### if (result < 0) 3074 ###### RETPUSHUNDEF; 3075 ###### RETPUSHNO; 3076 } 3077 else 3078 3758 result = my_stat(); 3079 #else 3080 result = my_stat(); 3081 #endif 3082 3757 SPAGAIN; 3083 3757 if (result < 0) 3084 2946 RETPUSHUNDEF; 3085 811 if (cando(S_IXUSR, 1, &PL_statcache)) 3086 805 RETPUSHYES; 3087 6 RETPUSHNO; 3088 } 3089 3090 PP(pp_ftis) 3091 3450 { 3092 3450 I32 result; 3093 3450 dSP; 3094 3450 STACKED_FTEST_CHECK; 3095 3448 result = my_stat(); 3096 3448 SPAGAIN; 3097 3448 if (result < 0) 3098 1126 RETPUSHUNDEF; 3099 2322 RETPUSHYES; 3100 } 3101 3102 PP(pp_fteowned) 3103 2 { 3104 2 return pp_ftrowned(); 3105 } 3106 3107 PP(pp_ftrowned) 3108 3 { 3109 3 I32 result; 3110 3 dSP; 3111 3 STACKED_FTEST_CHECK; 3112 3 result = my_stat(); 3113 3 SPAGAIN; 3114 3 if (result < 0) 3115 2 RETPUSHUNDEF; 3116 1 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? 3117 PL_euid : PL_uid) ) 3118 1 RETPUSHYES; 3119 ###### RETPUSHNO; 3120 } 3121 3122 PP(pp_ftzero) 3123 9 { 3124 9 I32 result; 3125 9 dSP; 3126 9 STACKED_FTEST_CHECK; 3127 9 result = my_stat(); 3128 9 SPAGAIN; 3129 9 if (result < 0) 3130 1 RETPUSHUNDEF; 3131 8 if (PL_statcache.st_size == 0) 3132 3 RETPUSHYES; 3133 5 RETPUSHNO; 3134 } 3135 3136 PP(pp_ftsize) 3137 4920 { 3138 4920 I32 result; 3139 4920 dSP; dTARGET; 3140 4920 STACKED_FTEST_CHECK; 3141 4920 result = my_stat(); 3142 4920 SPAGAIN; 3143 4920 if (result < 0) 3144 62 RETPUSHUNDEF; 3145 #if Off_t_size > IVSIZE 3146 4858 PUSHn(PL_statcache.st_size); 3147 #else 3148 PUSHi(PL_statcache.st_size); 3149 #endif 3150 4858 RETURN; 3151 } 3152 3153 PP(pp_ftmtime) 3154 51 { 3155 51 I32 result; 3156 51 dSP; dTARGET; 3157 51 STACKED_FTEST_CHECK; 3158 51 result = my_stat(); 3159 51 SPAGAIN; 3160 51 if (result < 0) 3161 1 RETPUSHUNDEF; 3162 50 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 ); 3163 50 RETURN; 3164 } 3165 3166 PP(pp_ftatime) 3167 3 { 3168 3 I32 result; 3169 3 dSP; dTARGET; 3170 3 STACKED_FTEST_CHECK; 3171 3 result = my_stat(); 3172 3 SPAGAIN; 3173 3 if (result < 0) 3174 1 RETPUSHUNDEF; 3175 2 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 ); 3176 2 RETURN; 3177 } 3178 3179 PP(pp_ftctime) 3180 3 { 3181 3 I32 result; 3182 3 dSP; dTARGET; 3183 3 STACKED_FTEST_CHECK; 3184 3 result = my_stat(); 3185 3 SPAGAIN; 3186 3 if (result < 0) 3187 1 RETPUSHUNDEF; 3188 2 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 ); 3189 2 RETURN; 3190 } 3191 3192 PP(pp_ftsock) 3193 7570 { 3194 7570 I32 result; 3195 7570 dSP; 3196 7570 STACKED_FTEST_CHECK; 3197 7570 result = my_stat(); 3198 7570 SPAGAIN; 3199 7570 if (result < 0) 3200 1 RETPUSHUNDEF; 3201 7569 if (S_ISSOCK(PL_statcache.st_mode)) 3202 3 RETPUSHYES; 3203 7566 RETPUSHNO; 3204 } 3205 3206 PP(pp_ftchr) 3207 7574 { 3208 7574 I32 result; 3209 7574 dSP; 3210 7574 STACKED_FTEST_CHECK; 3211 7574 result = my_stat(); 3212 7574 SPAGAIN; 3213 7574 if (result < 0) 3214 1 RETPUSHUNDEF; 3215 7573 if (S_ISCHR(PL_statcache.st_mode)) 3216 2121 RETPUSHYES; 3217 5452 RETPUSHNO; 3218 } 3219 3220 PP(pp_ftblk) 3221 7569 { 3222 7569 I32 result; 3223 7569 dSP; 3224 7569 STACKED_FTEST_CHECK; 3225 7569 result = my_stat(); 3226 7569 SPAGAIN; 3227 7569 if (result < 0) 3228 1 RETPUSHUNDEF; 3229 7568 if (S_ISBLK(PL_statcache.st_mode)) 3230 5422 RETPUSHYES; 3231 2146 RETPUSHNO; 3232 } 3233 3234 PP(pp_ftfile) 3235 5184 { 3236 5184 I32 result; 3237 5184 dSP; 3238 5184 STACKED_FTEST_CHECK; 3239 5181 result = my_stat(); 3240 5181 SPAGAIN; 3241 5181 if (result < 0) 3242 2346 RETPUSHUNDEF; 3243 2835 if (S_ISREG(PL_statcache.st_mode)) 3244 2667 RETPUSHYES; 3245 168 RETPUSHNO; 3246 } 3247 3248 PP(pp_ftdir) 3249 15197 { 3250 15197 I32 result; 3251 15197 dSP; 3252 15197 STACKED_FTEST_CHECK; 3253 15197 result = my_stat(); 3254 15197 SPAGAIN; 3255 15197 if (result < 0) 3256 2513 RETPUSHUNDEF; 3257 12684 if (S_ISDIR(PL_statcache.st_mode)) 3258 6932 RETPUSHYES; 3259 5752 RETPUSHNO; 3260 } 3261 3262 PP(pp_ftpipe) 3263 1 { 3264 1 I32 result; 3265 1 dSP; 3266 1 STACKED_FTEST_CHECK; 3267 1 result = my_stat(); 3268 1 SPAGAIN; 3269 1 if (result < 0) 3270 1 RETPUSHUNDEF; 3271 ###### if (S_ISFIFO(PL_statcache.st_mode)) 3272 ###### RETPUSHYES; 3273 ###### RETPUSHNO; 3274 } 3275 3276 PP(pp_ftlink) 3277 383 { 3278 383 I32 result = my_lstat(); 3279 381 dSP; 3280 381 if (result < 0) 3281 6 RETPUSHUNDEF; 3282 375 if (S_ISLNK(PL_statcache.st_mode)) 3283 21 RETPUSHYES; 3284 354 RETPUSHNO; 3285 } 3286 3287 PP(pp_ftsuid) 3288 124 { 3289 124 dSP; 3290 #ifdef S_ISUID 3291 124 I32 result; 3292 124 STACKED_FTEST_CHECK; 3293 124 result = my_stat(); 3294 124 SPAGAIN; 3295 124 if (result < 0) 3296 1 RETPUSHUNDEF; 3297 123 if (PL_statcache.st_mode & S_ISUID) 3298 1 RETPUSHYES; 3299 #endif 3300 122 RETPUSHNO; 3301 } 3302 3303 PP(pp_ftsgid) 3304 1 { 3305 1 dSP; 3306 #ifdef S_ISGID 3307 1 I32 result; 3308 1 STACKED_FTEST_CHECK; 3309 1 result = my_stat(); 3310 1 SPAGAIN; 3311 1 if (result < 0) 3312 1 RETPUSHUNDEF; 3313 ###### if (PL_statcache.st_mode & S_ISGID) 3314 ###### RETPUSHYES; 3315 #endif 3316 ###### RETPUSHNO; 3317 } 3318 3319 PP(pp_ftsvtx) 3320 2 { 3321 2 dSP; 3322 #ifdef S_ISVTX 3323 2 I32 result; 3324 2 STACKED_FTEST_CHECK; 3325 2 result = my_stat(); 3326 2 SPAGAIN; 3327 2 if (result < 0) 3328 ###### RETPUSHUNDEF; 3329 2 if (PL_statcache.st_mode & S_ISVTX) 3330 2 RETPUSHYES; 3331 #endif 3332 ###### RETPUSHNO; 3333 } 3334 3335 PP(pp_fttty) 3336 1079 { 3337 1079 dSP; 3338 1079 int fd; 3339 1079 GV *gv; 3340 1079 SV *tmpsv = Nullsv; 3341 3342 1079 STACKED_FTEST_CHECK; 3343 3344 1079 if (PL_op->op_flags & OPf_REF) 3345 1078 gv = cGVOP_gv; 3346 1 else if (isGV(TOPs)) 3347 ###### gv = (GV*)POPs; 3348 1 else if (SvROK(TOPs) && isGV(SvRV(TOPs))) 3349 ###### gv = (GV*)SvRV(POPs); 3350 else 3351 1 gv = gv_fetchsv(tmpsv = POPs, FALSE, SVt_PVIO); 3352 3353 1079 if (GvIO(gv) && IoIFP(GvIOp(gv))) 3354 1075 fd = PerlIO_fileno(IoIFP(GvIOp(gv))); 3355 4 else if (tmpsv && SvOK(tmpsv)) { 3356 ###### const char *tmps = SvPV_nolen_const(tmpsv); 3357 ###### if (isDIGIT(*tmps)) 3358 ###### fd = atoi(tmps); 3359 else 3360 ###### RETPUSHUNDEF; 3361 } 3362 else 3363 4 RETPUSHUNDEF; 3364 1075 if (PerlLIO_isatty(fd)) 3365 1018 RETPUSHYES; 3366 57 RETPUSHNO; 3367 } 3368 3369 #if defined(atarist) /* this will work with atariST. Configure will 3370 make guesses for other systems. */ 3371 # define FILE_base(f