pp_sys.c

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