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