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 {
 235     Uid_t ruid = getuid();
 236     Uid_t euid = geteuid();
 237     Gid_t rgid = getgid();
 238     Gid_t egid = getegid();
 239     int res;
 240
 241     MUTEX_LOCK(&PL_cred_mutex);
 242 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
 243     croak("switching effective uid is not implemented");
 244 #else
 245 #ifdef HAS_SETREUID
 246     if (setreuid(euid, ruid))
 247 #else
 248 #ifdef HAS_SETRESUID
 249     if (setresuid(euid, ruid, (Uid_t)-1))
 250 #endif
 251 #endif
 252         croak("entering effective uid failed");
 253 #endif
 254
 255 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
 256     croak("switching effective gid is not implemented");
 257 #else
 258 #ifdef HAS_SETREGID
 259     if (setregid(egid, rgid))
 260 #else
 261 #ifdef HAS_SETRESGID
 262     if (setresgid(egid, rgid, (Gid_t)-1))
 263 #endif
 264 #endif
 265         croak("entering effective gid failed");
 266 #endif
 267
 268     res = access(path, mode);
 269
 270 #ifdef HAS_SETREUID
 271     if (setreuid(ruid, euid))
 272 #else
 273 #ifdef HAS_SETRESUID
 274     if (setresuid(ruid, euid, (Uid_t)-1))
 275 #endif
 276 #endif
 277         croak("leaving effective uid failed");
 278
 279 #ifdef HAS_SETREGID
 280     if (setregid(rgid, egid))
 281 #else
 282 #ifdef HAS_SETRESGID
 283     if (setresgid(rgid, egid, (Gid_t)-1))
 284 #endif
 285 #endif
 286         croak("leaving effective gid failed");
 287     MUTEX_UNLOCK(&PL_cred_mutex);
 288
 289     return res;
 290 }
 291 #   define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
 292 #   define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
 293 #   define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
 294 #endif
 295
 296 #if !defined(PERL_EFF_ACCESS_R_OK)
 297 STATIC int
 298 emulate_eaccess (const char* path, int mode)
 299 {
 300     croak("switching effective uid is not implemented");
 301     /*NOTREACHED*/
 302     return -1;
 303 }
 304 #endif
 305
 306 PP(pp_backtick)
 307 {
 308     djSP; dTARGET;
 309     PerlIO *fp;
 310     STRLEN n_a;
 311     char *tmps = POPpx;
 312     I32 gimme = GIMME_V;
 313
 314     TAINT_PROPER("``");
 315     fp = PerlProc_popen(tmps, "r");
 316     if (fp) {
 317         if (gimme == G_VOID) {
 318             char tmpbuf[256];
 319             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
 320                 /*SUPPRESS 530*/
 321                 ;
 322         }
 323         else if (gimme == G_SCALAR) {
 324             sv_setpv(TARG, ""); /* note that this preserves previous buffer */
 325             while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
 326                 /*SUPPRESS 530*/
 327                 ;
 328             XPUSHs(TARG);
 329             SvTAINTED_on(TARG);
 330         }
 331         else {
 332             SV *sv;
 333
 334             for (;;) {
 335                 sv = NEWSV(56, 79);
 336                 if (sv_gets(sv, fp, 0) == Nullch) {
 337                     SvREFCNT_dec(sv);
 338                     break;
 339                 }
 340                 XPUSHs(sv_2mortal(sv));
 341                 if (SvLEN(sv) - SvCUR(sv) > 20) {
 342                     SvLEN_set(sv, SvCUR(sv)+1);
 343                     Renew(SvPVX(sv), SvLEN(sv), char);
 344                 }
 345                 SvTAINTED_on(sv);
 346             }
 347         }
 348         STATUS_NATIVE_SET(PerlProc_pclose(fp));
 349         TAINT;          /* "I believe that this is not gratuitous!" */
 350     }
 351     else {
 352         STATUS_NATIVE_SET(-1);
 353         if (gimme == G_SCALAR)
 354             RETPUSHUNDEF;
 355     }
 356
 357     RETURN;
 358 }
 359
 360 PP(pp_glob)
 361 {
 362     OP *result;
 363     tryAMAGICunTARGET(iter, -1);
 364
 365     ENTER;
 366
 367 #ifndef VMS
 368     if (PL_tainting) {
 369         /*
 370          * The external globbing program may use things we can't control,
 371          * so for security reasons we must assume the worst.
 372          */
 373         TAINT;
 374         taint_proper(PL_no_security, "glob");
 375     }
 376 #endif /* !VMS */
 377
 378     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
 379     PL_last_in_gv = (GV*)*PL_stack_sp--;
 380
 381     SAVESPTR(PL_rs);            /* This is not permanent, either. */
 382     PL_rs = sv_2mortal(newSVpvn("\000", 1));
 383 #ifndef DOSISH
 384 #ifndef CSH
 385     *SvPVX(PL_rs) = '\n';
 386 #endif  /* !CSH */
 387 #endif  /* !DOSISH */
 388
 389     result = do_readline();
 390     LEAVE;
 391     return result;
 392 }
 393
 394 #if 0           /* XXX never used! */
 395 PP(pp_indread)
 396 {
 397     STRLEN n_a;
 398     PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
 399     return do_readline();
 400 }
 401 #endif
 402
 403 PP(pp_rcatline)
 404 {
 405     PL_last_in_gv = cGVOP->op_gv;
 406     return do_readline();
 407 }
 408
 409 PP(pp_warn)
 410 {
 411     djSP; dMARK;
 412     SV *tmpsv;
 413     char *tmps;
 414     STRLEN len;
 415     if (SP - MARK != 1) {
 416         dTARGET;
 417         do_join(TARG, &PL_sv_no, MARK, SP);
 418         tmpsv = TARG;
 419         SP = MARK + 1;
 420     }
 421     else {
 422         tmpsv = TOPs;
 423     }
 424     tmps = SvPV(tmpsv, len);
 425     if (!tmps || !len) {
 426         SV *error = ERRSV;
 427         (void)SvUPGRADE(error, SVt_PV);
 428         if (SvPOK(error) && SvCUR(error))
 429             sv_catpv(error, "\t...caught");
 430         tmpsv = error;
 431         tmps = SvPV(tmpsv, len);
 432     }
 433     if (!tmps || !len)
 434         tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
 435
 436     warn("%_", tmpsv);
 437     RETSETYES;
 438 }
 439
 440 PP(pp_die)
 441 {
 442     djSP; dMARK;
 443     char *tmps;
 444     SV *tmpsv;
 445     STRLEN len;
 446     bool multiarg = 0;
 447     if (SP - MARK != 1) {
 448         dTARGET;
 449         do_join(TARG, &PL_sv_no, MARK, SP);
 450         tmpsv = TARG;
 451         tmps = SvPV(tmpsv, len);
 452         multiarg = 1;
 453         SP = MARK + 1;
 454     }
 455     else {
 456         tmpsv = TOPs;
 457         tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
 458     }
 459     if (!tmps || !len) {
 460         SV *error = ERRSV;
 461         (void)SvUPGRADE(error, SVt_PV);
 462         if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
 463             if (!multiarg)
 464                 SvSetSV(error,tmpsv);
 465             else if (sv_isobject(error)) {
 466                 HV *stash = SvSTASH(SvRV(error));
 467                 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
 468                 if (gv) {
 469                     SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
 470                     SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
 471                     EXTEND(SP, 3);
 472                     PUSHMARK(SP);
 473                     PUSHs(error);
 474                     PUSHs(file);
 475                     PUSHs(line);
 476                     PUTBACK;
 477                     perl_call_sv((SV*)GvCV(gv),
 478                                  G_SCALAR|G_EVAL|G_KEEPERR);
 479                     sv_setsv(error,*PL_stack_sp--);
 480                 }
 481             }
 482             DIE(Nullch);
 483         }
 484         else {
 485             if (SvPOK(error) && SvCUR(error))
 486                 sv_catpv(error, "\t...propagated");
 487             tmpsv = error;
 488             tmps = SvPV(tmpsv, len);
 489         }
 490     }
 491     if (!tmps || !len)
 492         tmpsv = sv_2mortal(newSVpvn("Died", 4));
 493
 494     DIE("%_", tmpsv);
 495 }
 496
 497 /* I/O. */
 498
 499 PP(pp_open)
 500 {
 501     djSP; dTARGET;
 502     GV *gv;
 503     SV *sv;
 504     char *tmps;
 505     STRLEN len;
 506     MAGIC *mg;
 507
 508     if (MAXARG > 1)
 509         sv = POPs;
 510     if (!isGV(TOPs))
 511         DIE(PL_no_usym, "filehandle");
 512     if (MAXARG <= 1)
 513         sv = GvSV(TOPs);
 514     gv = (GV*)POPs;
 515     if (!isGV(gv))
 516         DIE(PL_no_usym, "filehandle");
 517     if (GvIOp(gv))
 518         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
 519
 520 #if 0 /* no undef means tmpfile() yet */
 521     if (sv == &PL_sv_undef) {
 522 #ifdef PerlIO
 523         PerlIO *fp = PerlIO_tmpfile();
 524 #else
 525         PerlIO *fp = tmpfile();
 526 #endif
 527         if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
 528             PUSHi( (I32)PL_forkprocess );
 529         else
 530             RETPUSHUNDEF;
 531         RETURN;
 532     }
 533 #endif /* no undef means tmpfile() yet */
 534
 535
 536     if (mg = SvTIED_mg((SV*)gv, 'q')) {
 537         PUSHMARK(SP);
 538         XPUSHs(SvTIED_obj((SV*)gv, mg));
 539         XPUSHs(sv);
 540         PUTBACK;
 541         ENTER;
 542         perl_call_method("OPEN", G_SCALAR);
 543         LEAVE;
 544         SPAGAIN;
 545         RETURN;
 546     }
 547
 548     tmps = SvPV(sv, len);
 549     if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
 550         PUSHi( (I32)PL_forkprocess );
 551     else if (PL_forkprocess == 0)               /* we are a new child */
 552         PUSHi(0);
 553     else
 554         RETPUSHUNDEF;
 555     RETURN;
 556 }
 557
 558 PP(pp_close)
 559 {
 560     djSP;
 561     GV *gv;
 562     MAGIC *mg;
 563
 564     if (MAXARG == 0)
 565         gv = PL_defoutgv;
 566     else
 567         gv = (GV*)POPs;
 568
 569     if (mg = SvTIED_mg((SV*)gv, 'q')) {
 570         PUSHMARK(SP);
 571         XPUSHs(SvTIED_obj((SV*)gv, mg));
 572         PUTBACK;
 573         ENTER;
 574         perl_call_method("CLOSE", G_SCALAR);
 575         LEAVE;
 576         SPAGAIN;
 577         RETURN;
 578     }
 579     EXTEND(SP, 1);
 580     PUSHs(boolSV(do_close(gv, TRUE)));
 581     RETURN;
 582 }
 583
 584 PP(pp_pipe_op)
 585 {
 586     djSP;
 587 #ifdef HAS_PIPE
 588     GV *rgv;
 589     GV *wgv;
 590     register IO *rstio;
 591     register IO *wstio;
 592     int fd[2];
 593
 594     wgv = (GV*)POPs;
 595     rgv = (GV*)POPs;
 596
 597     if (!rgv || !wgv)
 598         goto badexit;
 599
 600     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
 601         DIE(PL_no_usym, "filehandle");
 602     rstio = GvIOn(rgv);
 603     wstio = GvIOn(wgv);
 604
 605     if (IoIFP(rstio))
 606         do_close(rgv, FALSE);
 607     if (IoIFP(wstio))
 608         do_close(wgv, FALSE);
 609
 610     if (PerlProc_pipe(fd) < 0)
 611         goto badexit;
 612
 613     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
 614     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
 615     IoIFP(wstio) = IoOFP(wstio);
 616     IoTYPE(rstio) = '<';
 617     IoTYPE(wstio) = '>';
 618
 619     if (!IoIFP(rstio) || !IoOFP(wstio)) {
 620         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
 621         else PerlLIO_close(fd[0]);
 622         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
 623         else PerlLIO_close(fd[1]);
 624         goto badexit;
 625     }
 626 #if defined(HAS_FCNTL) && defined(F_SETFD)
 627     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
 628     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
 629 #endif
 630     RETPUSHYES;
 631
 632 badexit:
 633     RETPUSHUNDEF;
 634 #else
 635     DIE(PL_no_func, "pipe");
 636 #endif
 637 }
 638
 639 PP(pp_fileno)
 640 {
 641     djSP; dTARGET;
 642     GV *gv;
 643     IO *io;
 644     PerlIO *fp;
 645     MAGIC  *mg;
 646
 647     if (MAXARG < 1)
 648         RETPUSHUNDEF;
 649     gv = (GV*)POPs;
 650
 651     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 652         PUSHMARK(SP);
 653         XPUSHs(SvTIED_obj((SV*)gv, mg));
 654         PUTBACK;
 655         ENTER;
 656         perl_call_method("FILENO", G_SCALAR);
 657         LEAVE;
 658         SPAGAIN;
 659         RETURN;
 660     }
 661
 662     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
 663         RETPUSHUNDEF;
 664     PUSHi(PerlIO_fileno(fp));
 665     RETURN;
 666 }
 667
 668 PP(pp_umask)
 669 {
 670     djSP; dTARGET;
 671     Mode_t anum;
 672
 673 #ifdef HAS_UMASK
 674     if (MAXARG < 1) {
 675         anum = PerlLIO_umask(0);
 676         (void)PerlLIO_umask(anum);
 677     }
 678     else
 679         anum = PerlLIO_umask(POPi);
 680     TAINT_PROPER("umask");
 681     XPUSHi(anum);
 682 #else
 683     /* Only DIE if trying to restrict permissions on `user' (self).
 684      * Otherwise it's harmless and more useful to just return undef
 685      * since 'group' and 'other' concepts probably don't exist here. */
 686     if (MAXARG >= 1 && (POPi & 0700))
 687         DIE("umask not implemented");
 688     XPUSHs(&PL_sv_undef);
 689 #endif
 690     RETURN;
 691 }
 692
 693 PP(pp_binmode)
 694 {
 695     djSP;
 696     GV *gv;
 697     IO *io;
 698     PerlIO *fp;
 699     MAGIC *mg;
 700
 701     if (MAXARG < 1)
 702         RETPUSHUNDEF;
 703
 704     gv = (GV*)POPs;
 705
 706     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
 707         PUSHMARK(SP);
 708         XPUSHs(SvTIED_obj((SV*)gv, mg));
 709         PUTBACK;
 710         ENTER;
 711         perl_call_method("BINMODE", G_SCALAR);
 712         LEAVE;
 713         SPAGAIN;
 714         RETURN;
 715     }
 716
 717     EXTEND(SP, 1);
 718     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
 719         RETPUSHUNDEF;
 720
 721     if (do_binmode(fp,IoTYPE(io),TRUE))
 722         RETPUSHYES;
 723     else
 724         RETPUSHUNDEF;
 725 }
 726
 727
 728 PP(pp_tie)
 729 {
 730     djSP;
 731     dMARK;
 732     SV *varsv;
 733     HV* stash;
 734     GV *gv;
 735     SV *sv;
 736     I32 markoff = MARK - PL_stack_base;
 737     char *methname;
 738     int how = 'P';
 739     U32 items;
 740     STRLEN n_a;
 741
 742     varsv = *++MARK;
 743     switch(SvTYPE(varsv)) {
 744         case SVt_PVHV:
 745             methname = "TIEHASH";
 746             break;
 747         case SVt_PVAV:
 748             methname = "TIEARRAY";
 749             break;
 750         case SVt_PVGV:
 751             methname = "TIEHANDLE";
 752             how = 'q';
 753             break;
 754         default:
 755             methname = "TIESCALAR";
 756             how = 'q';
 757             break;
 758     }
 759     items = SP - MARK++;
 760     if (sv_isobject(*MARK)) {
 761         ENTER;
 762         PUSHSTACKi(PERLSI_MAGIC);
 763         PUSHMARK(SP);
 764         EXTEND(SP,items);
 765         while (items--)
 766             PUSHs(*MARK++);
 767         PUTBACK;
 768         perl_call_method(methname, G_SCALAR);
 769     }
 770     else {
 771         /* Not clear why we don't call perl_call_method here too.
 772          * perhaps to get different error message ?
 773          */
 774         stash = gv_stashsv(*MARK, FALSE);
 775         if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
 776             DIE("Can't locate object method \"%s\" via package \"%s\"",
 777                  methname, SvPV(*MARK,n_a));
 778         }
 779         ENTER;
 780         PUSHSTACKi(PERLSI_MAGIC);
 781         PUSHMARK(SP);
 782         EXTEND(SP,items);
 783         while (items--)
 784             PUSHs(*MARK++);
 785         PUTBACK;
 786         perl_call_sv((SV*)GvCV(gv), G_SCALAR);
 787     }
 788     SPAGAIN;
 789
 790     sv = TOPs;
 791     POPSTACK;
 792     if (sv_isobject(sv)) {
 793         sv_unmagic(varsv, how);
 794         sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
 795     }
 796     LEAVE;
 797     SP = PL_stack_base + markoff;
 798     PUSHs(sv);
 799     RETURN;
 800 }
 801
 802 PP(pp_untie)
 803 {
 804     djSP;
 805     SV *sv = POPs;
 806     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 807
 808     if (ckWARN(WARN_UNTIE)) {
 809         MAGIC * mg ;
 810         if (mg = SvTIED_mg(sv, how)) {
 811             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
 812                 warner(WARN_UNTIE,
 813                     "untie attempted while %lu inner references still exist",
 814                     (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
 815         }
 816     }
 817
 818     sv_unmagic(sv, how);
 819     RETPUSHYES;
 820 }
 821
 822 PP(pp_tied)
 823 {
 824     djSP;
 825     SV *sv = POPs;
 826     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 827     MAGIC *mg;
 828
 829     if (mg = SvTIED_mg(sv, how)) {
 830         SV *osv = SvTIED_obj(sv, mg);
 831         if (osv == mg->mg_obj)
 832             osv = sv_mortalcopy(osv);
 833         PUSHs(osv);
 834         RETURN;
 835     }
 836     RETPUSHUNDEF;
 837 }
 838
 839 PP(pp_dbmopen)
 840 {
 841     djSP;
 842     HV *hv;
 843     dPOPPOPssrl;
 844     HV* stash;
 845     GV *gv;
 846     SV *sv;
 847
 848     hv = (HV*)POPs;
 849
 850     sv = sv_mortalcopy(&PL_sv_no);
 851     sv_setpv(sv, "AnyDBM_File");
 852     stash = gv_stashsv(sv, FALSE);
 853     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
 854         PUTBACK;
 855         perl_require_pv("AnyDBM_File.pm");
 856         SPAGAIN;
 857         if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
 858             DIE("No dbm on this machine");
 859     }
 860
 861     ENTER;
 862     PUSHMARK(SP);
 863
 864     EXTEND(SP, 5);
 865     PUSHs(sv);
 866     PUSHs(left);
 867     if (SvIV(right))
 868         PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
 869     else
 870         PUSHs(sv_2mortal(newSViv(O_RDWR)));
 871     PUSHs(right);
 872     PUTBACK;
 873     perl_call_sv((SV*)GvCV(gv), G_SCALAR);
 874     SPAGAIN;
 875
 876     if (!sv_isobject(TOPs)) {
 877         SP--;
 878         PUSHMARK(SP);
 879         PUSHs(sv);
 880         PUSHs(left);
 881         PUSHs(sv_2mortal(newSViv(O_RDONLY)));
 882         PUSHs(right);
 883         PUTBACK;
 884         perl_call_sv((SV*)GvCV(gv), G_SCALAR);
 885         SPAGAIN;
 886     }
 887
 888     if (sv_isobject(TOPs)) {
 889         sv_unmagic((SV *) hv, 'P');
 890         sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
 891     }
 892     LEAVE;
 893     RETURN;
 894 }
 895
 896 PP(pp_dbmclose)
 897 {
 898     return pp_untie(ARGS);
 899 }
 900
 901 PP(pp_sselect)
 902 {
 903     djSP; dTARGET;
 904 #ifdef HAS_SELECT
 905     register I32 i;
 906     register I32 j;
 907     register char *s;
 908     register SV *sv;
 909     double value;
 910     I32 maxlen = 0;
 911     I32 nfound;
 912     struct timeval timebuf;
 913     struct timeval *tbuf = &timebuf;
 914     I32 growsize;
 915     char *fd_sets[4];
 916     STRLEN n_a;
 917 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 918         I32 masksize;
 919         I32 offset;
 920         I32 k;
 921
 922 #   if BYTEORDER & 0xf0000
 923 #       define ORDERBYTE (0x88888888 - BYTEORDER)
 924 #   else
 925 #       define ORDERBYTE (0x4444 - BYTEORDER)
 926 #   endif
 927
 928 #endif
 929
 930     SP -= 4;
 931     for (i = 1; i <= 3; i++) {
 932         if (!SvPOK(SP[i]))
 933             continue;
 934         j = SvCUR(SP[i]);
 935         if (maxlen < j)
 936             maxlen = j;
 937     }
 938
 939 /* little endians can use vecs directly */
 940 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 941 #  if SELECT_MIN_BITS > 1
 942     /* If SELECT_MIN_BITS is greater than one we most probably will want
 943      * to align the sizes with SELECT_MIN_BITS/8 because for example
 944      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
 945      * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
 946      * on (sets/tests/clears bits) is 32 bits.  */
 947     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
 948 #  else
 949     growsize = sizeof(fd_set);
 950 #  endif
 951 # else
 952 #  ifdef NFDBITS
 953
 954 #    ifndef NBBY
 955 #     define NBBY 8
 956 #    endif
 957
 958     masksize = NFDBITS / NBBY;
 959 #  else
 960     masksize = sizeof(long);    /* documented int, everyone seems to use long */
 961 #  endif
 962     growsize = maxlen + (masksize - (maxlen % masksize));
 963     Zero(&fd_sets[0], 4, char*);
 964 #endif
 965
 966     sv = SP[4];
 967     if (SvOK(sv)) {
 968         value = SvNV(sv);
 969         if (value < 0.0)
 970             value = 0.0;
 971         timebuf.tv_sec = (long)value;
 972         value -= (double)timebuf.tv_sec;
 973         timebuf.tv_usec = (long)(value * 1000000.0);
 974     }
 975     else
 976         tbuf = Null(struct timeval*);
 977
 978     for (i = 1; i <= 3; i++) {
 979         sv = SP[i];
 980         if (!SvOK(sv)) {
 981             fd_sets[i] = 0;
 982             continue;
 983         }
 984         else if (!SvPOK(sv))
 985             SvPV_force(sv,n_a); /* force string conversion */
 986         j = SvLEN(sv);
 987         if (j < growsize) {
 988             Sv_Grow(sv, growsize);
 989         }
 990         j = SvCUR(sv);
 991         s = SvPVX(sv) + j;
 992         while (++j <= growsize) {
 993             *s++ = '\0';
 994         }
 995
 996 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
 997         s = SvPVX(sv);
 998         New(403, fd_sets[i], growsize, char);
 999         for (offset = 0; offset < growsize; offset += masksize) {
1000             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1001                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1002         }
1003 #else
1004         fd_sets[i] = SvPVX(sv);
1005 #endif
1006     }
1007
1008     nfound = PerlSock_select(
1009         maxlen * 8,
1010         (Select_fd_set_t) fd_sets[1],
1011         (Select_fd_set_t) fd_sets[2],
1012         (Select_fd_set_t) fd_sets[3],
1013         tbuf);
1014     for (i = 1; i <= 3; i++) {
1015         if (fd_sets[i]) {
1016             sv = SP[i];
1017 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1018             s = SvPVX(sv);
1019             for (offset = 0; offset < growsize; offset += masksize) {
1020                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1021                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1022             }
1023             Safefree(fd_sets[i]);
1024 #endif
1025             SvSETMAGIC(sv);
1026         }
1027     }
1028
1029     PUSHi(nfound);
1030     if (GIMME == G_ARRAY && tbuf) {
1031         value = (double)(timebuf.tv_sec) +
1032                 (double)(timebuf.tv_usec) / 1000000.0;
1033         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1034         sv_setnv(sv, value);
1035     }
1036     RETURN;
1037 #else
1038     DIE("select not implemented");
1039 #endif
1040 }
1041
1042 void
1043 setdefout(GV *gv)
1044 {
1045     dTHR;
1046     if (gv)
1047         (void)SvREFCNT_inc(gv);
1048     if (PL_defoutgv)
1049         SvREFCNT_dec(PL_defoutgv);
1050     PL_defoutgv = gv;
1051 }
1052
1053 PP(pp_select)
1054 {
1055     djSP; dTARGET;
1056     GV *newdefout, *egv;
1057     HV *hv;
1058
1059     newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
1060
1061     egv = GvEGV(PL_defoutgv);
1062     if (!egv)
1063         egv = PL_defoutgv;
1064     hv = GvSTASH(egv);
1065     if (! hv)
1066         XPUSHs(&PL_sv_undef);
1067     else {
1068         GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1069         if (gvp && *gvp == egv) {
1070             gv_efullname3(TARG, PL_defoutgv, Nullch);
1071             XPUSHTARG;
1072         }
1073         else {
1074             XPUSHs(sv_2mortal(newRV((SV*)egv)));
1075         }
1076     }
1077
1078     if (newdefout) {
1079         if (!GvIO(newdefout))
1080             gv_IOadd(newdefout);
1081         setdefout(newdefout);
1082     }
1083
1084     RETURN;
1085 }
1086
1087 PP(pp_getc)
1088 {
1089     djSP; dTARGET;
1090     GV *gv;
1091     MAGIC *mg;
1092
1093     if (MAXARG <= 0)
1094         gv = PL_stdingv;
1095     else
1096         gv = (GV*)POPs;
1097     if (!gv)
1098         gv = PL_argvgv;
1099
1100     if (mg = SvTIED_mg((SV*)gv, 'q')) {
1101         I32 gimme = GIMME_V;
1102         PUSHMARK(SP);
1103         XPUSHs(SvTIED_obj((SV*)gv, mg));
1104         PUTBACK;
1105         ENTER;
1106         perl_call_method("GETC", gimme);
1107         LEAVE;
1108         SPAGAIN;
1109         if (gimme == G_SCALAR)
1110             SvSetMagicSV_nosteal(TARG, TOPs);
1111         RETURN;
1112     }
1113     if (!gv || do_eof(gv)) /* make sure we have fp with something */
1114         RETPUSHUNDEF;
1115     TAINT;
1116     sv_setpv(TARG, " ");
1117     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1118     PUSHTARG;
1119     RETURN;
1120 }
1121
1122 PP(pp_read)
1123 {
1124     return pp_sysread(ARGS);
1125 }
1126
1127 STATIC OP *
1128 doform(CV *cv, GV *gv, OP *retop)
1129 {
1130     dTHR;
1131     register PERL_CONTEXT *cx;
1132     I32 gimme = GIMME_V;
1133     AV* padlist = CvPADLIST(cv);
1134     SV** svp = AvARRAY(padlist);
1135
1136     ENTER;
1137     SAVETMPS;
1138
1139     push_return(retop);
1140     PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
1141     PUSHFORMAT(cx);
1142     SAVESPTR(PL_curpad);
1143     PL_curpad = AvARRAY((AV*)svp[1]);
1144
1145     setdefout(gv);          /* locally select filehandle so $% et al work */
1146     return CvSTART(cv);
1147 }
1148
1149 PP(pp_enterwrite)
1150 {
1151     djSP;
1152     register GV *gv;
1153     register IO *io;
1154     GV *fgv;
1155     CV *cv;
1156
1157     if (MAXARG == 0)
1158         gv = PL_defoutgv;
1159     else {
1160         gv = (GV*)POPs;
1161         if (!gv)
1162             gv = PL_defoutgv;
1163     }
1164     EXTEND(SP, 1);
1165     io = GvIO(gv);
1166     if (!io) {
1167         RETPUSHNO;
1168     }
1169     if (IoFMT_GV(io))
1170         fgv = IoFMT_GV(io);
1171     else
1172         fgv = gv;
1173
1174     cv = GvFORM(fgv);
1175     if (!cv) {
1176         if (fgv) {
1177             SV *tmpsv = sv_newmortal();
1178             gv_efullname3(tmpsv, fgv, Nullch);
1179             DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
1180         }
1181         DIE("Not a format reference");
1182     }
1183     if (CvCLONE(cv))
1184         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1185
1186     IoFLAGS(io) &= ~IOf_DIDTOP;
1187     return doform(cv,gv,PL_op->op_next);
1188 }
1189
1190 PP(pp_leavewrite)
1191 {
1192     djSP;
1193     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1194     register IO *io = GvIOp(gv);
1195     PerlIO *ofp = IoOFP(io);
1196     PerlIO *fp;
1197     SV **newsp;
1198     I32 gimme;
1199     register PERL_CONTEXT *cx;
1200
1201     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1202           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1203     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1204         PL_formtarget != PL_toptarget)
1205     {
1206         GV *fgv;
1207         CV *cv;
1208         if (!IoTOP_GV(io)) {
1209             GV *topgv;
1210             SV *topname;
1211
1212             if (!IoTOP_NAME(io)) {
1213                 if (!IoFMT_NAME(io))
1214                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1215                 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1216                 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1217                 if ((topgv && GvFORM(topgv)) ||
1218                   !gv_fetchpv("top",FALSE,SVt_PVFM))
1219                     IoTOP_NAME(io) = savepv(SvPVX(topname));
1220                 else
1221                     IoTOP_NAME(io) = savepv("top");
1222             }
1223             topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1224             if (!topgv || !GvFORM(topgv)) {
1225                 IoLINES_LEFT(io) = 100000000;
1226                 goto forget_top;
1227             }
1228             IoTOP_GV(io) = topgv;
1229         }
1230         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1231             I32 lines = IoLINES_LEFT(io);
1232             char *s = SvPVX(PL_formtarget);
1233             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1234                 goto forget_top;
1235             while (lines-- > 0) {
1236                 s = strchr(s, '\n');
1237                 if (!s)
1238                     break;
1239                 s++;
1240             }
1241             if (s) {
1242                 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1243                 sv_chop(PL_formtarget, s);
1244                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1245             }
1246         }
1247         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1248             PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
1249         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1250         IoPAGE(io)++;
1251         PL_formtarget = PL_toptarget;
1252         IoFLAGS(io) |= IOf_DIDTOP;
1253         fgv = IoTOP_GV(io);
1254         if (!fgv)
1255             DIE("bad top format reference");
1256         cv = GvFORM(fgv);
1257         if (!cv) {
1258             SV *tmpsv = sv_newmortal();
1259             gv_efullname3(tmpsv, fgv, Nullch);
1260             DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1261         }
1262         if (CvCLONE(cv))
1263             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1264         return doform(cv,gv,PL_op);
1265     }
1266
1267   forget_top:
1268     POPBLOCK(cx,PL_curpm);
1269     POPFORMAT(cx);
1270     LEAVE;
1271
1272     fp = IoOFP(io);
1273     if (!fp) {
1274         if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1275             if (IoIFP(io))
1276                 warner(WARN_IO, "Filehandle only opened for input");
1277             else if (ckWARN(WARN_CLOSED))
1278                 warner(WARN_CLOSED, "Write on closed filehandle");
1279         }
1280         PUSHs(&PL_sv_no);
1281     }
1282     else {
1283         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1284             if (ckWARN(WARN_IO))
1285                 warner(WARN_IO, "page overflow");
1286         }
1287         if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
1288                 PerlIO_error(fp))
1289             PUSHs(&PL_sv_no);
1290         else {
1291             FmLINES(PL_formtarget) = 0;
1292             SvCUR_set(PL_formtarget, 0);
1293             *SvEND(PL_formtarget) = '\0';
1294             if (IoFLAGS(io) & IOf_FLUSH)
1295                 (void)PerlIO_flush(fp);
1296             PUSHs(&PL_sv_yes);
1297         }
1298     }
1299     PL_formtarget = PL_bodytarget;
1300     PUTBACK;
1301     return pop_return();
1302 }
1303
1304 PP(pp_prtf)
1305 {
1306     djSP; dMARK; dORIGMARK;
1307     GV *gv;
1308     IO *io;
1309     PerlIO *fp;
1310     SV *sv;
1311     MAGIC *mg;
1312     STRLEN n_a;
1313
1314     if (PL_op->op_flags & OPf_STACKED)
1315         gv = (GV*)*++MARK;
1316     else
1317         gv = PL_defoutgv;
1318
1319     if (mg = SvTIED_mg((SV*)gv, 'q')) {
1320         if (MARK == ORIGMARK) {
1321             MEXTEND(SP, 1);
1322             ++MARK;
1323             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1324             ++SP;
1325         }
1326         PUSHMARK(MARK - 1);
1327         *MARK = SvTIED_obj((SV*)gv, mg);
1328         PUTBACK;
1329         ENTER;
1330         perl_call_method("PRINTF", G_SCALAR);
1331         LEAVE;
1332         SPAGAIN;
1333         MARK = ORIGMARK + 1;
1334         *MARK = *SP;
1335         SP = MARK;
1336         RETURN;
1337     }
1338
1339     sv = NEWSV(0,0);
1340     if (!(io = GvIO(gv))) {
1341         if (ckWARN(WARN_UNOPENED)) {
1342             gv_fullname3(sv, gv, Nullch);
1343             warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
1344         }
1345         SETERRNO(EBADF,RMS$_IFI);
1346         goto just_say_no;
1347     }
1348     else if (!(fp = IoOFP(io))) {
1349         if (ckWARN2(WARN_CLOSED,WARN_IO))  {
1350             gv_fullname3(sv, gv, Nullch);
1351             if (IoIFP(io))
1352                 warner(WARN_IO, "Filehandle %s opened only for input",
1353                         SvPV(sv,n_a));
1354             else if (ckWARN(WARN_CLOSED))
1355                 warner(WARN_CLOSED, "printf on closed filehandle %s",
1356                         SvPV(sv,n_a));
1357         }
1358         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
1359         goto just_say_no;
1360     }
1361     else {
1362 #ifdef USE_LOCALE_NUMERIC
1363         if (PL_op->op_private & OPpLOCALE)
1364             SET_NUMERIC_LOCAL();
1365         else
1366             SET_NUMERIC_STANDARD();
1367 #endif
1368         do_sprintf(sv, SP - MARK, MARK + 1);
1369         if (!do_print(sv, fp))
1370             goto just_say_no;
1371
1372         if (IoFLAGS(io) & IOf_FLUSH)
1373             if (PerlIO_flush(fp) == EOF)
1374                 goto just_say_no;
1375     }
1376     SvREFCNT_dec(sv);
1377     SP = ORIGMARK;
1378     PUSHs(&PL_sv_yes);
1379     RETURN;
1380
1381   just_say_no:
1382     SvREFCNT_dec(sv);
1383     SP = ORIGMARK;
1384     PUSHs(&PL_sv_undef);
1385     RETURN;
1386 }
1387
1388 PP(pp_sysopen)
1389 {
1390     djSP;
1391     GV *gv;
1392     SV *sv;
1393     char *tmps;
1394     STRLEN len;
1395     int mode, perm;
1396
1397     if (MAXARG > 3)
1398         perm = POPi;
1399     else
1400         perm = 0666;
1401     mode = POPi;
1402     sv = POPs;
1403     gv = (GV *)POPs;
1404
1405     /* Need TIEHANDLE method ? */
1406
1407     tmps = SvPV(sv, len);
1408     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1409         IoLINES(GvIOp(gv)) = 0;
1410         PUSHs(&PL_sv_yes);
1411     }
1412     else {
1413         PUSHs(&PL_sv_undef);
1414     }
1415     RETURN;
1416 }
1417
1418 PP(pp_sysread)
1419 {
1420     djSP; dMARK; dORIGMARK; dTARGET;
1421     int offset;
1422     GV *gv;
1423     IO *io;
1424     char *buffer;
1425     SSize_t length;
1426     Sock_size_t bufsize;
1427     SV *bufsv;
1428     STRLEN blen;
1429     MAGIC *mg;
1430
1431     gv = (GV*)*++MARK;
1432     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
1433         (mg = SvTIED_mg((SV*)gv, 'q')))
1434     {
1435         SV *sv;
1436
1437         PUSHMARK(MARK-1);
1438         *MARK = SvTIED_obj((SV*)gv, mg);
1439         ENTER;
1440         perl_call_method("READ", G_SCALAR);
1441         LEAVE;
1442         SPAGAIN;
1443         sv = POPs;
1444         SP = ORIGMARK;
1445         PUSHs(sv);
1446         RETURN;
1447     }
1448
1449     if (!gv)
1450         goto say_undef;
1451     bufsv = *++MARK;
1452     if (! SvOK(bufsv))
1453         sv_setpvn(bufsv, "", 0);
1454     buffer = SvPV_force(bufsv, blen);
1455     length = SvIVx(*++MARK);
1456     if (length < 0)
1457         DIE("Negative length");
1458     SETERRNO(0,0);
1459     if (MARK < SP)
1460         offset = SvIVx(*++MARK);
1461     else
1462         offset = 0;
1463     io = GvIO(gv);
1464     if (!io || !IoIFP(io))
1465         goto say_undef;
1466 #ifdef HAS_SOCKET
1467     if (PL_op->op_type == OP_RECV) {
1468         char namebuf[MAXPATHLEN];
1469 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
1470         bufsize = sizeof (struct sockaddr_in);
1471 #else
1472         bufsize = sizeof namebuf;
1473 #endif
1474         buffer = SvGROW(bufsv, length+1);
1475         /* 'offset' means 'flags' here */
1476         length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1477                           (struct sockaddr *)namebuf, &bufsize);
1478         if (length < 0)
1479             RETPUSHUNDEF;
1480         SvCUR_set(bufsv, length);
1481         *SvEND(bufsv) = '\0';
1482         (void)SvPOK_only(bufsv);
1483         SvSETMAGIC(bufsv);
1484         /* This should not be marked tainted if the fp is marked clean */
1485         if (!(IoFLAGS(io) & IOf_UNTAINT))
1486             SvTAINTED_on(bufsv);
1487         SP = ORIGMARK;
1488         sv_setpvn(TARG, namebuf, bufsize);
1489         PUSHs(TARG);
1490         RETURN;
1491     }
1492 #else
1493     if (PL_op->op_type == OP_RECV)
1494         DIE(PL_no_sock_func, "recv");
1495 #endif
1496     if (offset < 0) {
1497         if (-offset > blen)
1498             DIE("Offset outside string");
1499         offset += blen;
1500     }
1501     bufsize = SvCUR(bufsv);
1502     buffer = SvGROW(bufsv, length+offset+1);
1503     if (offset > bufsize) { /* Zero any newly allocated space */
1504         Zero(buffer+bufsize, offset-bufsize, char);
1505     }
1506     if (PL_op->op_type == OP_SYSREAD) {
1507 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1508         if (IoTYPE(io) == 's') {
1509             length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1510                                    buffer+offset, length, 0);
1511         }
1512         else
1513 #endif
1514         {
1515             length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1516                                   buffer+offset, length);
1517         }
1518     }
1519     else
1520 #ifdef HAS_SOCKET__bad_code_maybe
1521     if (IoTYPE(io) == 's') {
1522         char namebuf[MAXPATHLEN];
1523 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1524         bufsize = sizeof (struct sockaddr_in);
1525 #else
1526         bufsize = sizeof namebuf;
1527 #endif
1528         length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
1529                           (struct sockaddr *)namebuf, &bufsize);
1530     }
1531     else
1532 #endif
1533     {
1534         length = PerlIO_read(IoIFP(io), buffer+offset, length);
1535         /* fread() returns 0 on both error and EOF */
1536         if (length == 0 && PerlIO_error(IoIFP(io)))
1537             length = -1;
1538     }
1539     if (length < 0)
1540         goto say_undef;
1541     SvCUR_set(bufsv, length+offset);
1542     *SvEND(bufsv) = '\0';
1543     (void)SvPOK_only(bufsv);
1544     SvSETMAGIC(bufsv);
1545     /* This should not be marked tainted if the fp is marked clean */
1546     if (!(IoFLAGS(io) & IOf_UNTAINT))
1547         SvTAINTED_on(bufsv);
1548     SP = ORIGMARK;
1549     PUSHi(length);
1550     RETURN;
1551
1552   say_undef:
1553     SP = ORIGMARK;
1554     RETPUSHUNDEF;
1555 }
1556
1557 PP(pp_syswrite)
1558 {
1559     djSP;
1560     int items = (SP - PL_stack_base) - TOPMARK;
1561     if (items == 2) {
1562         SV *sv;
1563         EXTEND(SP, 1);
1564         sv = sv_2mortal(newSViv(sv_len(*SP)));
1565         PUSHs(sv);
1566         PUTBACK;
1567     }
1568     return pp_send(ARGS);
1569 }
1570
1571 PP(pp_send)
1572 {
1573     djSP; dMARK; dORIGMARK; dTARGET;
1574     GV *gv;
1575     IO *io;
1576     int offset;
1577     SV *bufsv;
1578     char *buffer;
1579     int length;
1580     STRLEN blen;
1581     MAGIC *mg;
1582
1583     gv = (GV*)*++MARK;
1584     if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1585         SV *sv;
1586
1587         PUSHMARK(MARK-1);
1588         *MARK = SvTIED_obj((SV*)gv, mg);
1589         ENTER;
1590         perl_call_method("WRITE", G_SCALAR);
1591         LEAVE;
1592         SPAGAIN;
1593         sv = POPs;
1594         SP = ORIGMARK;
1595         PUSHs(sv);
1596         RETURN;
1597     }
1598     if (!gv)
1599         goto say_undef;
1600     bufsv = *++MARK;
1601     buffer = SvPV(bufsv, blen);
1602     length = SvIVx(*++MARK);
1603     if (length < 0)
1604         DIE("Negative length");
1605     SETERRNO(0,0);
1606     io = GvIO(gv);
1607     if (!io || !IoIFP(io)) {
1608         length = -1;
1609         if (ckWARN(WARN_CLOSED)) {
1610             if (PL_op->op_type == OP_SYSWRITE)
1611                 warner(WARN_CLOSED, "Syswrite on closed filehandle");
1612             else
1613                 warner(WARN_CLOSED, "Send on closed socket");
1614         }
1615     }
1616     else if (PL_op->op_type == OP_SYSWRITE) {
1617         if (MARK < SP) {
1618             offset = SvIVx(*++MARK);
1619             if (offset < 0) {
1620                 if (-offset > blen)
1621                     DIE("Offset outside string");
1622                 offset += blen;
1623             } else if (offset >= blen && blen > 0)
1624                 DIE("Offset outside string");
1625         } else
1626             offset = 0;
1627         if (length > blen - offset)
1628             length = blen - offset;
1629 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1630         if (IoTYPE(io) == 's') {
1631             length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1632                                    buffer+offset, length, 0);
1633         }
1634         else
1635 #endif
1636         {
1637             length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1638                                    buffer+offset, length);
1639         }
1640     }
1641 #ifdef HAS_SOCKET
1642     else if (SP > MARK) {
1643         char *sockbuf;
1644         STRLEN mlen;
1645         sockbuf = SvPVx(*++MARK, mlen);
1646         length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
1647                                 (struct sockaddr *)sockbuf, mlen);
1648     }
1649     else
1650         length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1651
1652 #else
1653     else
1654         DIE(PL_no_sock_func, "send");
1655 #endif
1656     if (length < 0)
1657         goto say_undef;
1658     SP = ORIGMARK;
1659     PUSHi(length);
1660     RETURN;
1661
1662   say_undef:
1663     SP = ORIGMARK;
1664     RETPUSHUNDEF;
1665 }
1666
1667 PP(pp_recv)
1668 {
1669     return pp_sysread(ARGS);
1670 }
1671
1672 PP(pp_eof)
1673 {
1674     djSP;
1675     GV *gv;
1676     MAGIC *mg;
1677
1678     if (MAXARG <= 0)
1679         gv = PL_last_in_gv;
1680     else
1681         gv = PL_last_in_gv = (GV*)POPs;
1682
1683     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1684         PUSHMARK(SP);
1685         XPUSHs(SvTIED_obj((SV*)gv, mg));
1686         PUTBACK;
1687         ENTER;
1688         perl_call_method("EOF", G_SCALAR);
1689         LEAVE;
1690         SPAGAIN;
1691         RETURN;
1692     }
1693
1694     PUSHs(boolSV(!gv || do_eof(gv)));
1695     RETURN;
1696 }
1697
1698 PP(pp_tell)
1699 {
1700     djSP; dTARGET;
1701     GV *gv;
1702     MAGIC *mg;
1703
1704     if (MAXARG <= 0)
1705         gv = PL_last_in_gv;
1706     else
1707         gv = PL_last_in_gv = (GV*)POPs;
1708
1709     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1710         PUSHMARK(SP);
1711         XPUSHs(SvTIED_obj((SV*)gv, mg));
1712         PUTBACK;
1713         ENTER;
1714         perl_call_method("TELL", G_SCALAR);
1715         LEAVE;
1716         SPAGAIN;
1717         RETURN;
1718     }
1719
1720     PUSHi( do_tell(gv) );
1721     RETURN;
1722 }
1723
1724 PP(pp_seek)
1725 {
1726     return pp_sysseek(ARGS);
1727 }
1728
1729 PP(pp_sysseek)
1730 {
1731     djSP;
1732     GV *gv;
1733     int whence = POPi;
1734     Off_t offset = POPl;
1735     MAGIC *mg;
1736
1737     gv = PL_last_in_gv = (GV*)POPs;
1738
1739     if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1740         PUSHMARK(SP);
1741         XPUSHs(SvTIED_obj((SV*)gv, mg));
1742         XPUSHs(sv_2mortal(newSViv((IV) offset)));
1743         XPUSHs(sv_2mortal(newSViv((IV) whence)));
1744         PUTBACK;
1745         ENTER;
1746         perl_call_method("SEEK", G_SCALAR);
1747         LEAVE;
1748         SPAGAIN;
1749         RETURN;
1750     }
1751
1752     if (PL_op->op_type == OP_SEEK)
1753         PUSHs(boolSV(do_seek(gv, offset, whence)));
1754     else {
1755         Off_t n = do_sysseek(gv, offset, whence);
1756         PUSHs((n < 0) ? &PL_sv_undef
1757               : sv_2mortal(n ? newSViv((IV)n)
1758                            : newSVpvn(zero_but_true, ZBTLEN)));
1759     }
1760     RETURN;
1761 }
1762
1763 PP(pp_truncate)
1764 {
1765     djSP;
1766     Off_t len = (Off_t)POPn;
1767     int result = 1;
1768     GV *tmpgv;
1769     STRLEN n_a;
1770
1771     SETERRNO(0,0);
1772 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1773     if (PL_op->op_flags & OPf_SPECIAL) {
1774         tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
1775     do_ftruncate:
1776         TAINT_PROPER("truncate");
1777         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
1778 #ifdef HAS_TRUNCATE
1779           ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1780 #else
1781           my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1782 #endif
1783             result = 0;
1784     }
1785     else {
1786         SV *sv = POPs;
1787         char *name;
1788         STRLEN n_a;
1789
1790         if (SvTYPE(sv) == SVt_PVGV) {
1791             tmpgv = (GV*)sv;            /* *main::FRED for example */
1792             goto do_ftruncate;
1793         }
1794         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1795             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1796             goto do_ftruncate;
1797         }
1798
1799         name = SvPV(sv, n_a);
1800         TAINT_PROPER("truncate");
1801 #ifdef HAS_TRUNCATE
1802         if (truncate(name, len) < 0)
1803             result = 0;
1804 #else
1805         {
1806             int tmpfd;
1807             if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
1808                 result = 0;
1809             else {
1810                 if (my_chsize(tmpfd, len) < 0)
1811                     result = 0;
1812                 PerlLIO_close(tmpfd);
1813             }
1814         }
1815 #endif
1816     }
1817
1818     if (result)
1819         RETPUSHYES;
1820     if (!errno)
1821         SETERRNO(EBADF,RMS$_IFI);
1822     RETPUSHUNDEF;
1823 #else
1824     DIE("truncate not implemented");
1825 #endif
1826 }
1827
1828 PP(pp_fcntl)
1829 {
1830     return pp_ioctl(ARGS);
1831 }
1832
1833 PP(pp_ioctl)
1834 {
1835     djSP; dTARGET;
1836     SV *argsv = POPs;
1837     unsigned int func = U_I(POPn);
1838     int optype = PL_op->op_type;
1839     char *s;
1840     IV retval;
1841     GV *gv = (GV*)POPs;
1842     IO *io = GvIOn(gv);
1843
1844     if (!io || !argsv || !IoIFP(io)) {
1845         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1846         RETPUSHUNDEF;
1847     }
1848
1849     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1850         STRLEN len;
1851         STRLEN need;
1852         s = SvPV_force(argsv, len);
1853         need = IOCPARM_LEN(func);
1854         if (len < need) {
1855             s = Sv_Grow(argsv, need + 1);
1856             SvCUR_set(argsv, need);
1857         }
1858
1859         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1860     }
1861     else {
1862         retval = SvIV(argsv);
1863         s = (char*)retval;              /* ouch */
1864     }
1865
1866     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1867
1868     if (optype == OP_IOCTL)
1869 #ifdef HAS_IOCTL
1870         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1871 #else
1872         DIE("ioctl is not implemented");
1873 #endif
1874     else
1875 #ifdef HAS_FCNTL
1876 #if defined(OS2) && defined(__EMX__)
1877         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1878 #else
1879         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1880 #endif
1881 #else
1882         DIE("fcntl is not implemented");
1883 #endif
1884
1885     if (SvPOK(argsv)) {
1886         if (s[SvCUR(argsv)] != 17)
1887             DIE("Possible memory corruption: %s overflowed 3rd argument",
1888                 PL_op_name[optype]);
1889         s[SvCUR(argsv)] = 0;            /* put our null back */
1890         SvSETMAGIC(argsv);              /* Assume it has changed */
1891     }
1892
1893     if (retval == -1)
1894         RETPUSHUNDEF;
1895     if (retval != 0) {
1896         PUSHi(retval);
1897     }
1898     else {
1899         PUSHp(zero_but_true, ZBTLEN);
1900     }
1901     RETURN;
1902 }
1903
1904 PP(pp_flock)
1905 {
1906     djSP; dTARGET;
1907     I32 value;
1908     int argtype;
1909     GV *gv;
1910     PerlIO *fp;
1911
1912 #ifdef FLOCK
1913     argtype = POPi;
1914     if (MAXARG <= 0)
1915         gv = PL_last_in_gv;
1916     else
1917         gv = (GV*)POPs;
1918     if (gv && GvIO(gv))
1919         fp = IoIFP(GvIOp(gv));
1920     else
1921         fp = Nullfp;
1922     if (fp) {
1923         (void)PerlIO_flush(fp);
1924         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
1925     }
1926     else
1927         value = 0;
1928     PUSHi(value);
1929     RETURN;
1930 #else
1931     DIE(PL_no_func, "flock()");
1932 #endif
1933 }
1934
1935 /* Sockets. */
1936
1937 PP(pp_socket)
1938 {
1939     djSP;
1940 #ifdef HAS_SOCKET
1941     GV *gv;
1942     register IO *io;
1943     int protocol = POPi;
1944     int type = POPi;
1945     int domain = POPi;
1946     int fd;
1947
1948     gv = (GV*)POPs;
1949
1950     if (!gv) {
1951         SETERRNO(EBADF,LIB$_INVARG);
1952         RETPUSHUNDEF;
1953     }
1954
1955     io = GvIOn(gv);
1956     if (IoIFP(io))
1957         do_close(gv, FALSE);
1958
1959     TAINT_PROPER("socket");
1960     fd = PerlSock_socket(domain, type, protocol);
1961     if (fd < 0)
1962         RETPUSHUNDEF;
1963     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1964     IoOFP(io) = PerlIO_fdopen(fd, "w");
1965     IoTYPE(io) = 's';
1966     if (!IoIFP(io) || !IoOFP(io)) {
1967         if (IoIFP(io)) PerlIO_close(IoIFP(io));
1968         if (IoOFP(io)) PerlIO_close(IoOFP(io));
1969         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
1970         RETPUSHUNDEF;
1971     }
1972
1973     RETPUSHYES;
1974 #else
1975     DIE(PL_no_sock_func, "socket");
1976 #endif
1977 }
1978
1979 PP(pp_sockpair)
1980 {
1981     djSP;
1982 #ifdef HAS_SOCKETPAIR
1983     GV *gv1;
1984     GV *gv2;
1985     register IO *io1;
1986     register IO *io2;
1987     int protocol = POPi;
1988     int type = POPi;
1989     int domain = POPi;
1990     int fd[2];
1991
1992     gv2 = (GV*)POPs;
1993     gv1 = (GV*)POPs;
1994     if (!gv1 || !gv2)
1995         RETPUSHUNDEF;
1996
1997     io1 = GvIOn(gv1);
1998     io2 = GvIOn(gv2);
1999     if (IoIFP(io1))
2000         do_close(gv1, FALSE);
2001     if (IoIFP(io2))
2002         do_close(gv2, FALSE);
2003
2004     TAINT_PROPER("socketpair");
2005     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2006         RETPUSHUNDEF;
2007     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2008     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
2009     IoTYPE(io1) = 's';
2010     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2011     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
2012     IoTYPE(io2) = 's';
2013     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2014         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2015         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2016         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2017         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2018         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2019         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2020         RETPUSHUNDEF;
2021     }
2022
2023     RETPUSHYES;
2024 #else
2025     DIE(PL_no_sock_func, "socketpair");
2026 #endif
2027 }
2028
2029 PP(pp_bind)
2030 {
2031     djSP;
2032 #ifdef HAS_SOCKET
2033 #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2034     extern GETPRIVMODE();
2035     extern GETUSERMODE();
2036 #endif
2037     SV *addrsv = POPs;
2038     char *addr;
2039     GV *gv = (GV*)POPs;
2040     register IO *io = GvIOn(gv);
2041     STRLEN len;
2042     int bind_ok = 0;
2043 #ifdef MPE
2044     int mpeprivmode = 0;
2045 #endif
2046
2047     if (!io || !IoIFP(io))
2048         goto nuts;
2049
2050     addr = SvPV(addrsv, len);
2051     TAINT_PROPER("bind");
2052 #ifdef MPE /* Deal with MPE bind() peculiarities */
2053     if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2054         /* The address *MUST* stupidly be zero. */
2055         ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2056         /* PRIV mode is required to bind() to ports < 1024. */
2057         if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2058             ((struct sockaddr_in *)addr)->sin_port > 0) {
2059             GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2060             mpeprivmode = 1;
2061         }
2062     }
2063 #endif /* MPE */
2064     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2065                       (struct sockaddr *)addr, len) >= 0)
2066         bind_ok = 1;
2067
2068 #ifdef MPE /* Switch back to USER mode */
2069     if (mpeprivmode)
2070         GETUSERMODE();
2071 #endif /* MPE */
2072
2073     if (bind_ok)
2074         RETPUSHYES;
2075     else
2076         RETPUSHUNDEF;
2077
2078 nuts:
2079     if (ckWARN(WARN_CLOSED))
2080         warner(WARN_CLOSED, "bind() on closed fd");
2081     SETERRNO(EBADF,SS$_IVCHAN);
2082     RETPUSHUNDEF;
2083 #else
2084     DIE(PL_no_sock_func, "bind");
2085 #endif
2086 }
2087
2088 PP(pp_connect)
2089 {
2090     djSP;
2091 #ifdef HAS_SOCKET
2092     SV *addrsv = POPs;
2093     char *addr;
2094     GV *gv = (GV*)POPs;
2095     register IO *io = GvIOn(gv);
2096     STRLEN len;
2097
2098     if (!io || !IoIFP(io))
2099         goto nuts;
2100
2101     addr = SvPV(addrsv, len);
2102     TAINT_PROPER("connect");
2103     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2104         RETPUSHYES;
2105     else
2106         RETPUSHUNDEF;
2107
2108 nuts:
2109     if (ckWARN(WARN_CLOSED))
2110         warner(WARN_CLOSED, "connect() on closed fd");
2111     SETERRNO(EBADF,SS$_IVCHAN);
2112     RETPUSHUNDEF;
2113 #else
2114     DIE(PL_no_sock_func, "connect");
2115 #endif
2116 }
2117
2118 PP(pp_listen)
2119 {
2120     djSP;
2121 #ifdef HAS_SOCKET
2122     int backlog = POPi;
2123     GV *gv = (GV*)POPs;
2124     register IO *io = GvIOn(gv);
2125
2126     if (!io || !IoIFP(io))
2127         goto nuts;
2128
2129     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2130         RETPUSHYES;
2131     else
2132         RETPUSHUNDEF;
2133
2134 nuts:
2135     if (ckWARN(WARN_CLOSED))
2136         warner(WARN_CLOSED, "listen() on closed fd");
2137     SETERRNO(EBADF,SS$_IVCHAN);
2138     RETPUSHUNDEF;
2139 #else
2140     DIE(PL_no_sock_func, "listen");
2141 #endif
2142 }
2143
2144 PP(pp_accept)
2145 {
2146     djSP; dTARGET;
2147 #ifdef HAS_SOCKET
2148     GV *ngv;
2149     GV *ggv;
2150     register IO *nstio;
2151     register IO *gstio;
2152     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
2153     Sock_size_t len = sizeof saddr;
2154     int fd;
2155
2156     ggv = (GV*)POPs;
2157     ngv = (GV*)POPs;
2158
2159     if (!ngv)
2160         goto badexit;
2161     if (!ggv)
2162         goto nuts;
2163
2164     gstio = GvIO(ggv);
2165     if (!gstio || !IoIFP(gstio))
2166         goto nuts;
2167
2168     nstio = GvIOn(ngv);
2169     if (IoIFP(nstio))
2170         do_close(ngv, FALSE);
2171
2172     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
2173     if (fd < 0)
2174         goto badexit;
2175     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2176     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
2177     IoTYPE(nstio) = 's';
2178     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2179         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2180         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2181         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2182         goto badexit;
2183     }
2184
2185     PUSHp((char *)&saddr, len);
2186     RETURN;
2187
2188 nuts:
2189     if (ckWARN(WARN_CLOSED))
2190         warner(WARN_CLOSED, "accept() on closed fd");
2191     SETERRNO(EBADF,SS$_IVCHAN);
2192
2193 badexit:
2194     RETPUSHUNDEF;
2195
2196 #else
2197     DIE(PL_no_sock_func, "accept");
2198 #endif
2199 }
2200
2201 PP(pp_shutdown)
2202 {
2203     djSP; dTARGET;
2204 #ifdef HAS_SOCKET
2205     int how = POPi;
2206     GV *gv = (GV*)POPs;
2207     register IO *io = GvIOn(gv);
2208
2209     if (!io || !IoIFP(io))
2210         goto nuts;
2211
2212     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2213     RETURN;
2214
2215 nuts:
2216     if (ckWARN(WARN_CLOSED))
2217         warner(WARN_CLOSED, "shutdown() on closed fd");
2218     SETERRNO(EBADF,SS$_IVCHAN);
2219     RETPUSHUNDEF;
2220 #else
2221     DIE(PL_no_sock_func, "shutdown");
2222 #endif
2223 }
2224
2225 PP(pp_gsockopt)
2226 {
2227 #ifdef HAS_SOCKET
2228     return pp_ssockopt(ARGS);
2229 #else
2230     DIE(PL_no_sock_func, "getsockopt");
2231 #endif
2232 }
2233
2234 PP(pp_ssockopt)
2235 {
2236     djSP;
2237 #ifdef HAS_SOCKET
2238     int optype = PL_op->op_type;
2239     SV *sv;
2240     int fd;
2241     unsigned int optname;
2242     unsigned int lvl;
2243     GV *gv;
2244     register IO *io;
2245     Sock_size_t len;
2246
2247     if (optype == OP_GSOCKOPT)
2248         sv = sv_2mortal(NEWSV(22, 257));
2249     else
2250         sv = POPs;
2251     optname = (unsigned int) POPi;
2252     lvl = (unsigned int) POPi;
2253
2254     gv = (GV*)POPs;
2255     io = GvIOn(gv);
2256     if (!io || !IoIFP(io))
2257         goto nuts;
2258
2259     fd = PerlIO_fileno(IoIFP(io));
2260     switch (optype) {
2261     case OP_GSOCKOPT:
2262         SvGROW(sv, 257);
2263         (void)SvPOK_only(sv);
2264         SvCUR_set(sv,256);
2265         *SvEND(sv) ='\0';
2266         len = SvCUR(sv);
2267         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2268             goto nuts2;
2269         SvCUR_set(sv, len);
2270         *SvEND(sv) ='\0';
2271         PUSHs(sv);
2272         break;
2273     case OP_SSOCKOPT: {
2274             char *buf;
2275             int aint;
2276             if (SvPOKp(sv)) {
2277                 STRLEN l;
2278                 buf = SvPV(sv, l);
2279                 len = l;
2280             }
2281             else {
2282                 aint = (int)SvIV(sv);
2283                 buf = (char*)&aint;
2284                 len = sizeof(int);
2285             }
2286             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2287                 goto nuts2;
2288             PUSHs(&PL_sv_yes);
2289         }
2290         break;
2291     }
2292     RETURN;
2293
2294 nuts:
2295     if (ckWARN(WARN_CLOSED))
2296         warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
2297     SETERRNO(EBADF,SS$_IVCHAN);
2298 nuts2:
2299     RETPUSHUNDEF;
2300
2301 #else
2302     DIE(PL_no_sock_func, "setsockopt");
2303 #endif
2304 }
2305
2306 PP(pp_getsockname)
2307 {
2308 #ifdef HAS_SOCKET
2309     return pp_getpeername(ARGS);
2310 #else
2311     DIE(PL_no_sock_func, "getsockname");
2312 #endif
2313 }
2314
2315 PP(pp_getpeername)
2316 {
2317     djSP;
2318 #ifdef HAS_SOCKET
2319     int optype = PL_op->op_type;
2320     SV *sv;
2321     int fd;
2322     GV *gv = (GV*)POPs;
2323     register IO *io = GvIOn(gv);
2324     Sock_size_t len;
2325
2326     if (!io || !IoIFP(io))
2327         goto nuts;
2328
2329     sv = sv_2mortal(NEWSV(22, 257));
2330     (void)SvPOK_only(sv);
2331     len = 256;
2332     SvCUR_set(sv, len);
2333     *SvEND(sv) ='\0';
2334     fd = PerlIO_fileno(IoIFP(io));
2335     switch (optype) {
2336     case OP_GETSOCKNAME:
2337         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2338             goto nuts2;
2339         break;
2340     case OP_GETPEERNAME:
2341         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2342             goto nuts2;
2343 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2344         {
2345             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";
2346             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2347             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2348                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2349                         sizeof(u_short) + sizeof(struct in_addr))) {
2350                 goto nuts2;
2351             }
2352         }
2353 #endif
2354         break;
2355     }
2356 #ifdef BOGUS_GETNAME_RETURN
2357     /* Interactive Unix, getpeername() and getsockname()
2358       does not return valid namelen */
2359     if (len == BOGUS_GETNAME_RETURN)
2360         len = sizeof(struct sockaddr);
2361 #endif
2362     SvCUR_set(sv, len);
2363     *SvEND(sv) ='\0';
2364     PUSHs(sv);
2365     RETURN;
2366
2367 nuts:
2368     if (ckWARN(WARN_CLOSED))
2369         warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
2370     SETERRNO(EBADF,SS$_IVCHAN);
2371 nuts2:
2372     RETPUSHUNDEF;
2373
2374 #else
2375     DIE(PL_no_sock_func, "getpeername");
2376 #endif
2377 }
2378
2379 /* Stat calls. */
2380
2381 PP(pp_lstat)
2382 {
2383     return pp_stat(ARGS);
2384 }
2385
2386 PP(pp_stat)
2387 {
2388     djSP;
2389     GV *tmpgv;
2390     I32 gimme;
2391     I32 max = 13;
2392     STRLEN n_a;
2393
2394     if (PL_op->op_flags & OPf_REF) {
2395         tmpgv = cGVOP->op_gv;
2396       do_fstat:
2397         if (tmpgv != PL_defgv) {
2398             PL_laststype = OP_STAT;
2399             PL_statgv = tmpgv;
2400             sv_setpv(PL_statname, "");
2401             PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2402                 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
2403         }
2404         if (PL_laststatval < 0)
2405             max = 0;
2406     }
2407     else {
2408         SV* sv = POPs;
2409         if (SvTYPE(sv) == SVt_PVGV) {
2410             tmpgv = (GV*)sv;
2411             goto do_fstat;
2412         }
2413         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2414             tmpgv = (GV*)SvRV(sv);
2415             goto do_fstat;
2416         }
2417         sv_setpv(PL_statname, SvPV(sv,n_a));
2418         PL_statgv = Nullgv;
2419 #ifdef HAS_LSTAT
2420         PL_laststype = PL_op->op_type;
2421         if (PL_op->op_type == OP_LSTAT)
2422             PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2423         else
2424 #endif
2425             PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2426         if (PL_laststatval < 0) {
2427             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2428                 warner(WARN_NEWLINE, PL_warn_nl, "stat");
2429             max = 0;
2430         }
2431     }
2432
2433     gimme = GIMME_V;
2434     if (gimme != G_ARRAY) {
2435         if (gimme != G_VOID)
2436             XPUSHs(boolSV(max));
2437         RETURN;
2438     }
2439     if (max) {
2440         EXTEND(SP, max);
2441         EXTEND_MORTAL(max);
2442         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2443         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2444         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2445         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2446         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2447         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
2448 #ifdef USE_STAT_RDEV
2449         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
2450 #else
2451         PUSHs(sv_2mortal(newSVpvn("", 0)));
2452 #endif
2453         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
2454 #ifdef BIG_TIME
2455         PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2456         PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2457         PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
2458 #else
2459         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2460         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2461         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
2462 #endif
2463 #ifdef USE_STAT_BLOCKS
2464         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2465         PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
2466 #else
2467         PUSHs(sv_2mortal(newSVpvn("", 0)));
2468         PUSHs(sv_2mortal(newSVpvn("", 0)));
2469 #endif
2470     }
2471     RETURN;
2472 }
2473
2474 PP(pp_ftrread)
2475 {
2476     I32 result;
2477     djSP;
2478 #if defined(HAS_ACCESS) && defined(R_OK)
2479     STRLEN n_a;
2480     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2481         result = access(TOPpx, R_OK);
2482         if (result == 0)
2483             RETPUSHYES;
2484         if (result < 0)
2485             RETPUSHUNDEF;
2486         RETPUSHNO;
2487     }
2488     else
2489         result = my_stat(ARGS);
2490 #else
2491     result = my_stat(ARGS);
2492 #endif
2493     SPAGAIN;
2494     if (result < 0)
2495         RETPUSHUNDEF;
2496     if (cando(S_IRUSR, 0, &PL_statcache))
2497         RETPUSHYES;
2498     RETPUSHNO;
2499 }
2500
2501 PP(pp_ftrwrite)
2502 {
2503     I32 result;
2504     djSP;
2505 #if defined(HAS_ACCESS) && defined(W_OK)
2506     STRLEN n_a;
2507     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2508         result = access(TOPpx, W_OK);
2509         if (result == 0)
2510             RETPUSHYES;
2511         if (result < 0)
2512             RETPUSHUNDEF;
2513         RETPUSHNO;
2514     }
2515     else
2516         result = my_stat(ARGS);
2517 #else
2518     result = my_stat(ARGS);
2519 #endif
2520     SPAGAIN;
2521     if (result < 0)
2522         RETPUSHUNDEF;
2523     if (cando(S_IWUSR, 0, &PL_statcache))
2524         RETPUSHYES;
2525     RETPUSHNO;
2526 }
2527
2528 PP(pp_ftrexec)
2529 {
2530     I32 result;
2531     djSP;
2532 #if defined(HAS_ACCESS) && defined(X_OK)
2533     STRLEN n_a;
2534     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2535         result = access(TOPpx, X_OK);
2536         if (result == 0)
2537             RETPUSHYES;
2538         if (result < 0)
2539             RETPUSHUNDEF;
2540         RETPUSHNO;
2541     }
2542     else
2543         result = my_stat(ARGS);
2544 #else
2545     result = my_stat(ARGS);
2546 #endif
2547     SPAGAIN;
2548     if (result < 0)
2549         RETPUSHUNDEF;
2550     if (cando(S_IXUSR, 0, &PL_statcache))
2551         RETPUSHYES;
2552     RETPUSHNO;
2553 }
2554
2555 PP(pp_fteread)
2556 {
2557     I32 result;
2558     djSP;
2559 #ifdef PERL_EFF_ACCESS_R_OK
2560     STRLEN n_a;
2561     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2562         result = PERL_EFF_ACCESS_R_OK(TOPpx);
2563         if (result == 0)
2564             RETPUSHYES;
2565         if (result < 0)
2566             RETPUSHUNDEF;
2567         RETPUSHNO;
2568     }
2569     else
2570         result = my_stat(ARGS);
2571 #else
2572     result = my_stat(ARGS);
2573 #endif
2574     SPAGAIN;
2575     if (result < 0)
2576         RETPUSHUNDEF;
2577     if (cando(S_IRUSR, 1, &PL_statcache))
2578         RETPUSHYES;
2579     RETPUSHNO;
2580 }
2581
2582 PP(pp_ftewrite)
2583 {
2584     I32 result;
2585     djSP;
2586 #ifdef PERL_EFF_ACCESS_W_OK
2587     STRLEN n_a;
2588     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2589         result = PERL_EFF_ACCESS_W_OK(TOPpx);
2590         if (result == 0)
2591             RETPUSHYES;
2592         if (result < 0)
2593             RETPUSHUNDEF;
2594         RETPUSHNO;
2595     }
2596     else
2597         result = my_stat(ARGS);
2598 #else
2599     result = my_stat(ARGS);
2600 #endif
2601     SPAGAIN;
2602     if (result < 0)
2603         RETPUSHUNDEF;
2604     if (cando(S_IWUSR, 1, &PL_statcache))
2605         RETPUSHYES;
2606     RETPUSHNO;
2607 }
2608
2609 PP(pp_fteexec)
2610 {
2611     I32 result;
2612     djSP;
2613 #ifdef PERL_EFF_ACCESS_X_OK
2614     STRLEN n_a;
2615     if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2616         result = PERL_EFF_ACCESS_X_OK(TOPpx);
2617         if (result == 0)
2618             RETPUSHYES;
2619         if (result < 0)
2620             RETPUSHUNDEF;
2621         RETPUSHNO;
2622     }
2623     else
2624         result = my_stat(ARGS);
2625 #else
2626     result = my_stat(ARGS);
2627 #endif
2628     SPAGAIN;
2629     if (result < 0)
2630         RETPUSHUNDEF;
2631     if (cando(S_IXUSR, 1, &PL_statcache))
2632         RETPUSHYES;
2633     RETPUSHNO;
2634 }
2635
2636 PP(pp_ftis)
2637 {
2638     I32 result = my_stat(ARGS);
2639     djSP;
2640     if (result < 0)
2641         RETPUSHUNDEF;
2642     RETPUSHYES;
2643 }
2644
2645 PP(pp_fteowned)
2646 {
2647     return pp_ftrowned(ARGS);
2648 }
2649
2650 PP(pp_ftrowned)
2651 {
2652     I32 result = my_stat(ARGS);
2653     djSP;
2654     if (result < 0)
2655         RETPUSHUNDEF;
2656     if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
2657         RETPUSHYES;
2658     RETPUSHNO;
2659 }
2660
2661 PP(pp_ftzero)
2662 {
2663     I32 result = my_stat(ARGS);
2664     djSP;
2665     if (result < 0)
2666         RETPUSHUNDEF;
2667     if (!PL_statcache.st_size)
2668         RETPUSHYES;
2669     RETPUSHNO;
2670 }
2671
2672 PP(pp_ftsize)
2673 {
2674     I32 result = my_stat(ARGS);
2675     djSP; dTARGET;
2676     if (result < 0)
2677         RETPUSHUNDEF;
2678     PUSHi(PL_statcache.st_size);
2679     RETURN;
2680 }
2681
2682 PP(pp_ftmtime)
2683 {
2684     I32 result = my_stat(ARGS);
2685     djSP; dTARGET;
2686     if (result < 0)
2687         RETPUSHUNDEF;
2688     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
2689     RETURN;
2690 }
2691
2692 PP(pp_ftatime)
2693 {
2694     I32 result = my_stat(ARGS);
2695     djSP; dTARGET;
2696     if (result < 0)
2697         RETPUSHUNDEF;
2698     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
2699     RETURN;
2700 }
2701
2702 PP(pp_ftctime)
2703 {
2704     I32 result = my_stat(ARGS);
2705     djSP; dTARGET;
2706     if (result < 0)
2707         RETPUSHUNDEF;
2708     PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
2709     RETURN;
2710 }
2711
2712 PP(pp_ftsock)
2713 {
2714     I32 result = my_stat(ARGS);
2715     djSP;
2716     if (result < 0)
2717         RETPUSHUNDEF;
2718     if (S_ISSOCK(PL_statcache.st_mode))
2719         RETPUSHYES;
2720     RETPUSHNO;
2721 }
2722
2723 PP(pp_ftchr)
2724 {
2725     I32 result = my_stat(ARGS);
2726     djSP;
2727     if (result < 0)
2728         RETPUSHUNDEF;
2729     if (S_ISCHR(PL_statcache.st_mode))
2730         RETPUSHYES;
2731     RETPUSHNO;
2732 }
2733
2734 PP(pp_ftblk)
2735 {
2736     I32 result = my_stat(ARGS);
2737     djSP;
2738     if (result < 0)
2739         RETPUSHUNDEF;
2740     if (S_ISBLK(PL_statcache.st_mode))
2741         RETPUSHYES;
2742     RETPUSHNO;
2743 }
2744
2745 PP(pp_ftfile)
2746 {
2747     I32 result = my_stat(ARGS);
2748     djSP;
2749     if (result < 0)
2750         RETPUSHUNDEF;
2751     if (S_ISREG(PL_statcache.st_mode))
2752         RETPUSHYES;
2753     RETPUSHNO;
2754 }
2755
2756 PP(pp_ftdir)
2757 {
2758     I32 result = my_stat(ARGS);
2759     djSP;
2760     if (result < 0)
2761         RETPUSHUNDEF;
2762     if (S_ISDIR(PL_statcache.st_mode))
2763         RETPUSHYES;
2764     RETPUSHNO;
2765 }
2766
2767 PP(pp_ftpipe)
2768 {
2769     I32 result = my_stat(ARGS);
2770     djSP;
2771     if (result < 0)
2772         RETPUSHUNDEF;
2773     if (S_ISFIFO(PL_statcache.st_mode))
2774         RETPUSHYES;
2775     RETPUSHNO;
2776 }
2777
2778 PP(pp_ftlink)
2779 {
2780     I32 result = my_lstat(ARGS);
2781     djSP;
2782     if (result < 0)
2783         RETPUSHUNDEF;
2784     if (S_ISLNK(PL_statcache.st_mode))
2785         RETPUSHYES;
2786     RETPUSHNO;
2787 }
2788
2789 PP(pp_ftsuid)
2790 {
2791     djSP;
2792 #ifdef S_ISUID
2793     I32 result = my_stat(ARGS);
2794     SPAGAIN;
2795     if (result < 0)
2796         RETPUSHUNDEF;
2797     if (PL_statcache.st_mode & S_ISUID)
2798         RETPUSHYES;
2799 #endif
2800     RETPUSHNO;
2801 }
2802
2803 PP(pp_ftsgid)
2804 {
2805     djSP;
2806 #ifdef S_ISGID
2807     I32 result = my_stat(ARGS);
2808     SPAGAIN;
2809     if (result < 0)
2810         RETPUSHUNDEF;
2811     if (PL_statcache.st_mode & S_ISGID)
2812         RETPUSHYES;
2813 #endif
2814     RETPUSHNO;
2815 }
2816
2817 PP(pp_ftsvtx)
2818 {
2819     djSP;
2820 #ifdef S_ISVTX
2821     I32 result = my_stat(ARGS);
2822     SPAGAIN;
2823     if (result < 0)
2824         RETPUSHUNDEF;
2825     if (PL_statcache.st_mode & S_ISVTX)
2826         RETPUSHYES;
2827 #endif
2828     RETPUSHNO;
2829 }
2830
2831 PP(pp_fttty)
2832 {
2833     djSP;
2834     int fd;
2835     GV *gv;
2836     char *tmps = Nullch;
2837     STRLEN n_a;
2838
2839     if (PL_op->op_flags & OPf_REF)
2840         gv = cGVOP->op_gv;
2841     else if (isGV(TOPs))
2842         gv = (GV*)POPs;
2843     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2844         gv = (GV*)SvRV(POPs);
2845     else
2846         gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
2847
2848     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2849         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2850     else if (tmps && isDIGIT(*tmps))
2851         fd = atoi(tmps);
2852     else
2853         RETPUSHUNDEF;
2854     if (PerlLIO_isatty(fd))
2855         RETPUSHYES;
2856     RETPUSHNO;
2857 }
2858
2859 #if defined(atarist) /* this will work with atariST. Configure will
2860                         make guesses for other systems. */
2861 # define FILE_base(f) ((f)->_base)
2862 # define FILE_ptr(f) ((f)->_ptr)
2863 # define FILE_cnt(f) ((f)->_cnt)
2864 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2865 #endif
2866
2867 PP(pp_fttext)
2868 {
2869     djSP;
2870     I32 i;
2871     I32 len;
2872     I32 odd = 0;
2873     STDCHAR tbuf[512];
2874     register STDCHAR *s;
2875     register IO *io;
2876     register SV *sv;
2877     GV *gv;
2878     STRLEN n_a;
2879
2880     if (PL_op->op_flags & OPf_REF)
2881         gv = cGVOP->op_gv;
2882     else if (isGV(TOPs))
2883         gv = (GV*)POPs;
2884     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2885         gv = (GV*)SvRV(POPs);
2886     else
2887         gv = Nullgv;
2888
2889     if (gv) {
2890         EXTEND(SP, 1);
2891         if (gv == PL_defgv) {
2892             if (PL_statgv)
2893                 io = GvIO(PL_statgv);
2894             else {
2895                 sv = PL_statname;
2896                 goto really_filename;
2897             }
2898         }
2899         else {
2900             PL_statgv = gv;
2901             PL_laststatval = -1;
2902             sv_setpv(PL_statname, "");
2903             io = GvIO(PL_statgv);
2904         }
2905         if (io && IoIFP(io)) {
2906             if (! PerlIO_has_base(IoIFP(io)))
2907                 DIE("-T and -B not implemented on filehandles");
2908             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2909             if (PL_laststatval < 0)
2910                 RETPUSHUNDEF;
2911             if (S_ISDIR(PL_statcache.st_mode))  /* handle NFS glitch */
2912                 if (PL_op->op_type == OP_FTTEXT)
2913                     RETPUSHNO;
2914                 else
2915                     RETPUSHYES;
2916             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2917                 i = PerlIO_getc(IoIFP(io));
2918                 if (i != EOF)
2919                     (void)PerlIO_ungetc(IoIFP(io),i);
2920             }
2921             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2922                 RETPUSHYES;
2923             len = PerlIO_get_bufsiz(IoIFP(io));
2924             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2925             /* sfio can have large buffers - limit to 512 */
2926             if (len > 512)
2927                 len = 512;
2928         }
2929         else {
2930             if (ckWARN(WARN_UNOPENED))
2931                 warner(WARN_UNOPENED, "Test on unopened file <%s>",
2932                   GvENAME(cGVOP->op_gv));
2933             SETERRNO(EBADF,RMS$_IFI);
2934             RETPUSHUNDEF;
2935         }
2936     }
2937     else {
2938         sv = POPs;
2939       really_filename:
2940         PL_statgv = Nullgv;
2941         PL_laststatval = -1;
2942         sv_setpv(PL_statname, SvPV(sv, n_a));
2943 #ifdef HAS_OPEN3
2944         i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
2945 #else
2946         i = PerlLIO_open(SvPV(sv, n_a), 0);
2947 #endif
2948         if (i < 0) {
2949             if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
2950                 warner(WARN_NEWLINE, PL_warn_nl, "open");
2951             RETPUSHUNDEF;
2952         }
2953         PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2954         if (PL_laststatval < 0)
2955             RETPUSHUNDEF;
2956         len = PerlLIO_read(i, tbuf, 512);
2957         (void)PerlLIO_close(i);
2958         if (len <= 0) {
2959             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
2960                 RETPUSHNO;              /* special case NFS directories */
2961             RETPUSHYES;         /* null file is anything */
2962         }
2963         s = tbuf;
2964     }
2965
2966     /* now scan s to look for textiness */
2967     /*   XXX ASCII dependent code */
2968
2969     for (i = 0; i < len; i++, s++) {
2970         if (!*s) {                      /* null never allowed in text */
2971             odd += len;
2972             break;
2973         }
2974 #ifdef EBCDIC
2975         else if (!(isPRINT(*s) || isSPACE(*s)))
2976             odd++;
2977 #else
2978         else if (*s & 128)
2979             odd++;
2980         else if (*s < 32 &&
2981           *s != '\n' && *s != '\r' && *s != '\b' &&
2982           *s != '\t' && *s != '\f' && *s != 27)
2983             odd++;
2984 #endif
2985     }
2986
2987     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2988         RETPUSHNO;
2989     else
2990         RETPUSHYES;
2991 }
2992
2993 PP(pp_ftbinary)
2994 {
2995     return pp_fttext(ARGS);
2996 }
2997
2998 /* File calls. */
2999
3000 PP(pp_chdir)
3001 {
3002     djSP; dTARGET;
3003     char *tmps;
3004     SV **svp;
3005     STRLEN n_a;
3006
3007     if (MAXARG < 1)
3008         tmps = Nullch;
3009     else
3010         tmps = POPpx;
3011     if (!tmps || !*tmps) {
3012         svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
3013         if (svp)
3014             tmps = SvPV(*svp, n_a);
3015     }
3016     if (!tmps || !*tmps) {
3017         svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
3018         if (svp)
3019             tmps = SvPV(*svp, n_a);
3020     }
3021 #ifdef VMS
3022     if (!tmps || !*tmps) {
3023        svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
3024        if (svp)
3025            tmps = SvPV(*svp, n_a);
3026     }
3027 #endif
3028     TAINT_PROPER("chdir");
3029     PUSHi( PerlDir_chdir(tmps) >= 0 );
3030 #ifdef VMS
3031     /* Clear the DEFAULT element of ENV so we'll get the new value
3032      * in the future. */
3033     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3034 #endif
3035     RETURN;
3036 }
3037
3038 PP(pp_chown)
3039 {
3040     djSP; dMARK; dTARGET;
3041     I32 value;
3042 #ifdef HAS_CHOWN
3043     value = (I32)apply(PL_op->op_type, MARK, SP);
3044     SP = MARK;
3045     PUSHi(value);
3046     RETURN;
3047 #else
3048     DIE(PL_no_func, "Unsupported function chown");
3049 #endif
3050 }
3051
3052 PP(pp_chroot)
3053 {
3054     djSP; dTARGET;
3055     char *tmps;
3056 #ifdef HAS_CHROOT
3057     STRLEN n_a;
3058     tmps = POPpx;
3059     TAINT_PROPER("chroot");
3060     PUSHi( chroot(tmps) >= 0 );
3061     RETURN;
3062 #else
3063     DIE(PL_no_func, "chroot");
3064 #endif
3065 }
3066
3067 PP(pp_unlink)
3068 {
3069     djSP; dMARK; dTARGET;
3070     I32 value;
3071     value = (I32)apply(PL_op->op_type, MARK, SP);
3072     SP = MARK;
3073     PUSHi(value);
3074     RETURN;
3075 }
3076
3077 PP(pp_chmod)
3078 {
3079     djSP; dMARK; dTARGET;
3080     I32 value;
3081     value = (I32)apply(PL_op->op_type, MARK, SP);
3082     SP = MARK;
3083     PUSHi(value);
3084     RETURN;
3085 }
3086
3087 PP(pp_utime)
3088 {
3089     djSP; dMARK; dTARGET;
3090     I32 value;
3091     value = (I32)apply(PL_op->op_type, MARK, SP);
3092     SP = MARK;
3093     PUSHi(value);
3094     RETURN;
3095 }
3096
3097 PP(pp_rename)
3098 {
3099     djSP; dTARGET;
3100     int anum;
3101     STRLEN n_a;
3102
3103     char *tmps2 = POPpx;
3104     char *tmps = SvPV(TOPs, n_a);
3105     TAINT_PROPER("rename");
3106 #ifdef HAS_RENAME
3107     anum = PerlLIO_rename(tmps, tmps2);
3108 #else
3109     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3110         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3111             anum = 1;
3112         else {
3113             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3114                 (void)UNLINK(tmps2);
3115             if (!(anum = link(tmps, tmps2)))
3116                 anum = UNLINK(tmps);
3117         }
3118     }
3119 #endif
3120     SETi( anum >= 0 );
3121     RETURN;
3122 }
3123
3124 PP(pp_link)
3125 {
3126     djSP; dTARGET;
3127 #ifdef HAS_LINK
3128     STRLEN n_a;
3129     char *tmps2 = POPpx;
3130     char *tmps = SvPV(TOPs, n_a);
3131     TAINT_PROPER("link");
3132     SETi( link(tmps, tmps2) >= 0 );
3133 #else
3134     DIE(PL_no_func, "Unsupported function link");
3135 #endif
3136     RETURN;
3137 }
3138
3139 PP(pp_symlink)
3140 {
3141     djSP; dTARGET;
3142 #ifdef HAS_SYMLINK
3143     STRLEN n_a;
3144     char *tmps2 = POPpx;
3145     char *tmps = SvPV(TOPs, n_a);
3146     TAINT_PROPER("symlink");
3147     SETi( symlink(tmps, tmps2) >= 0 );
3148     RETURN;
3149 #else
3150     DIE(PL_no_func, "symlink");
3151 #endif
3152 }
3153
3154 PP(pp_readlink)
3155 {
3156     djSP; dTARGET;
3157 #ifdef HAS_SYMLINK
3158     char *tmps;
3159     char buf[MAXPATHLEN];
3160     int len;
3161     STRLEN n_a;
3162
3163 #ifndef INCOMPLETE_TAINTS
3164     TAINT;
3165 #endif
3166     tmps = POPpx;
3167     len = readlink(tmps, buf, sizeof buf);
3168     EXTEND(SP, 1);
3169     if (len < 0)
3170         RETPUSHUNDEF;
3171     PUSHp(buf, len);
3172     RETURN;
3173 #else
3174     EXTEND(SP, 1);
3175     RETSETUNDEF;                /* just pretend it's a normal file */
3176 #endif
3177 }
3178
3179 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3180 STATIC int
3181 dooneliner(char *cmd, 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 (int fd, int operation)
4967 {
4968     int i;
4969     int save_errno;
4970     Off_t pos;
4971
4972     /* flock locks entire file so for lockf we need to do the same      */
4973     save_errno = errno;
4974     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
4975     if (pos > 0)        /* is seekable and needs to be repositioned     */
4976         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
4977             pos = -1;   /* seek failed, so don't seek back afterwards   */
4978     errno = save_errno;
4979
4980     switch (operation) {
4981
4982         /* LOCK_SH - get a shared lock */
4983         case LOCK_SH:
4984         /* LOCK_EX - get an exclusive lock */
4985         case LOCK_EX:
4986             i = lockf (fd, F_LOCK, 0);
4987             break;
4988
4989         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4990         case LOCK_SH|LOCK_NB:
4991         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4992         case LOCK_EX|LOCK_NB:
4993             i = lockf (fd, F_TLOCK, 0);
4994             if (i == -1)
4995                 if ((errno == EAGAIN) || (errno == EACCES))
4996                     errno = EWOULDBLOCK;
4997             break;
4998
4999         /* LOCK_UN - unlock (non-blocking is a no-op) */
5000         case LOCK_UN:
5001         case LOCK_UN|LOCK_NB:
5002             i = lockf (fd, F_ULOCK, 0);
5003             break;
5004
5005         /* Default - can't decipher operation */
5006         default:
5007             i = -1;
5008             errno = EINVAL;
5009             break;
5010     }
5011
5012     if (pos > 0)      /* need to restore position of the handle */
5013         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5014
5015     return (i);
5016 }
5017
5018 #endif /* LOCKF_EMULATE_FLOCK */