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