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