pp_sys.c

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