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