pp_sys.c

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