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