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