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 || op->op_type == OP_SYSREAD) &&
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     IV 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         STRLEN need;
1517         s = SvPV_force(argsv, len);
1518         need = IOCPARM_LEN(func);
1519         if (len < need) {
1520             s = Sv_Grow(argsv, need + 1);
1521             SvCUR_set(argsv, need);
1522         }
1523
1524         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1525     }
1526     else {
1527         retval = SvIV(argsv);
1528         s = (char*)retval;              /* ouch */
1529     }
1530
1531     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1532
1533     if (optype == OP_IOCTL)
1534 #ifdef HAS_IOCTL
1535         retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1536 #else
1537         DIE("ioctl is not implemented");
1538 #endif
1539     else
1540 #ifdef HAS_FCNTL
1541 #if defined(OS2) && defined(__EMX__)
1542         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1543 #else
1544         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1545 #endif
1546 #else
1547         DIE("fcntl is not implemented");
1548 #endif
1549
1550     if (SvPOK(argsv)) {
1551         if (s[SvCUR(argsv)] != 17)
1552             DIE("Possible memory corruption: %s overflowed 3rd argument",
1553                 op_name[optype]);
1554         s[SvCUR(argsv)] = 0;            /* put our null back */
1555         SvSETMAGIC(argsv);              /* Assume it has changed */
1556     }
1557
1558     if (retval == -1)
1559         RETPUSHUNDEF;
1560     if (retval != 0) {
1561         PUSHi(retval);
1562     }
1563     else {
1564         PUSHp(zero_but_true, ZBTLEN);
1565     }
1566     RETURN;
1567 }
1568
1569 PP(pp_flock)
1570 {
1571     dSP; dTARGET;
1572     I32 value;
1573     int argtype;
1574     GV *gv;
1575     PerlIO *fp;
1576
1577 #ifdef FLOCK
1578     argtype = POPi;
1579     if (MAXARG <= 0)
1580         gv = last_in_gv;
1581     else
1582         gv = (GV*)POPs;
1583     if (gv && GvIO(gv))
1584         fp = IoIFP(GvIOp(gv));
1585     else
1586         fp = Nullfp;
1587     if (fp) {
1588         (void)PerlIO_flush(fp);
1589         value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
1590     }
1591     else
1592         value = 0;
1593     PUSHi(value);
1594     RETURN;
1595 #else
1596     DIE(no_func, "flock()");
1597 #endif
1598 }
1599
1600 /* Sockets. */
1601
1602 PP(pp_socket)
1603 {
1604     dSP;
1605 #ifdef HAS_SOCKET
1606     GV *gv;
1607     register IO *io;
1608     int protocol = POPi;
1609     int type = POPi;
1610     int domain = POPi;
1611     int fd;
1612
1613     gv = (GV*)POPs;
1614
1615     if (!gv) {
1616         SETERRNO(EBADF,LIB$_INVARG);
1617         RETPUSHUNDEF;
1618     }
1619
1620     io = GvIOn(gv);
1621     if (IoIFP(io))
1622         do_close(gv, FALSE);
1623
1624     TAINT_PROPER("socket");
1625     fd = socket(domain, type, protocol);
1626     if (fd < 0)
1627         RETPUSHUNDEF;
1628     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1629     IoOFP(io) = PerlIO_fdopen(fd, "w");
1630     IoTYPE(io) = 's';
1631     if (!IoIFP(io) || !IoOFP(io)) {
1632         if (IoIFP(io)) PerlIO_close(IoIFP(io));
1633         if (IoOFP(io)) PerlIO_close(IoOFP(io));
1634         if (!IoIFP(io) && !IoOFP(io)) close(fd);
1635         RETPUSHUNDEF;
1636     }
1637
1638     RETPUSHYES;
1639 #else
1640     DIE(no_sock_func, "socket");
1641 #endif
1642 }
1643
1644 PP(pp_sockpair)
1645 {
1646     dSP;
1647 #ifdef HAS_SOCKETPAIR
1648     GV *gv1;
1649     GV *gv2;
1650     register IO *io1;
1651     register IO *io2;
1652     int protocol = POPi;
1653     int type = POPi;
1654     int domain = POPi;
1655     int fd[2];
1656
1657     gv2 = (GV*)POPs;
1658     gv1 = (GV*)POPs;
1659     if (!gv1 || !gv2)
1660         RETPUSHUNDEF;
1661
1662     io1 = GvIOn(gv1);
1663     io2 = GvIOn(gv2);
1664     if (IoIFP(io1))
1665         do_close(gv1, FALSE);
1666     if (IoIFP(io2))
1667         do_close(gv2, FALSE);
1668
1669     TAINT_PROPER("socketpair");
1670     if (socketpair(domain, type, protocol, fd) < 0)
1671         RETPUSHUNDEF;
1672     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1673     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
1674     IoTYPE(io1) = 's';
1675     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1676     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
1677     IoTYPE(io2) = 's';
1678     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
1679         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1680         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
1681         if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
1682         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1683         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
1684         if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
1685         RETPUSHUNDEF;
1686     }
1687
1688     RETPUSHYES;
1689 #else
1690     DIE(no_sock_func, "socketpair");
1691 #endif
1692 }
1693
1694 PP(pp_bind)
1695 {
1696     dSP;
1697 #ifdef HAS_SOCKET
1698     SV *addrsv = POPs;
1699     char *addr;
1700     GV *gv = (GV*)POPs;
1701     register IO *io = GvIOn(gv);
1702     STRLEN len;
1703
1704     if (!io || !IoIFP(io))
1705         goto nuts;
1706
1707     addr = SvPV(addrsv, len);
1708     TAINT_PROPER("bind");
1709     if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1710         RETPUSHYES;
1711     else
1712         RETPUSHUNDEF;
1713
1714 nuts:
1715     if (dowarn)
1716         warn("bind() on closed fd");
1717     SETERRNO(EBADF,SS$_IVCHAN);
1718     RETPUSHUNDEF;
1719 #else
1720     DIE(no_sock_func, "bind");
1721 #endif
1722 }
1723
1724 PP(pp_connect)
1725 {
1726     dSP;
1727 #ifdef HAS_SOCKET
1728     SV *addrsv = POPs;
1729     char *addr;
1730     GV *gv = (GV*)POPs;
1731     register IO *io = GvIOn(gv);
1732     STRLEN len;
1733
1734     if (!io || !IoIFP(io))
1735         goto nuts;
1736
1737     addr = SvPV(addrsv, len);
1738     TAINT_PROPER("connect");
1739     if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1740         RETPUSHYES;
1741     else
1742         RETPUSHUNDEF;
1743
1744 nuts:
1745     if (dowarn)
1746         warn("connect() on closed fd");
1747     SETERRNO(EBADF,SS$_IVCHAN);
1748     RETPUSHUNDEF;
1749 #else
1750     DIE(no_sock_func, "connect");
1751 #endif
1752 }
1753
1754 PP(pp_listen)
1755 {
1756     dSP;
1757 #ifdef HAS_SOCKET
1758     int backlog = POPi;
1759     GV *gv = (GV*)POPs;
1760     register IO *io = GvIOn(gv);
1761
1762     if (!io || !IoIFP(io))
1763         goto nuts;
1764
1765     if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
1766         RETPUSHYES;
1767     else
1768         RETPUSHUNDEF;
1769
1770 nuts:
1771     if (dowarn)
1772         warn("listen() on closed fd");
1773     SETERRNO(EBADF,SS$_IVCHAN);
1774     RETPUSHUNDEF;
1775 #else
1776     DIE(no_sock_func, "listen");
1777 #endif
1778 }
1779
1780 PP(pp_accept)
1781 {
1782     dSP; dTARGET;
1783 #ifdef HAS_SOCKET
1784     GV *ngv;
1785     GV *ggv;
1786     register IO *nstio;
1787     register IO *gstio;
1788     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
1789     Sock_size_t len = sizeof saddr;
1790     int fd;
1791
1792     ggv = (GV*)POPs;
1793     ngv = (GV*)POPs;
1794
1795     if (!ngv)
1796         goto badexit;
1797     if (!ggv)
1798         goto nuts;
1799
1800     gstio = GvIO(ggv);
1801     if (!gstio || !IoIFP(gstio))
1802         goto nuts;
1803
1804     nstio = GvIOn(ngv);
1805     if (IoIFP(nstio))
1806         do_close(ngv, FALSE);
1807
1808     fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
1809     if (fd < 0)
1810         goto badexit;
1811     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1812     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
1813     IoTYPE(nstio) = 's';
1814     if (!IoIFP(nstio) || !IoOFP(nstio)) {
1815         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1816         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
1817         if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
1818         goto badexit;
1819     }
1820
1821     PUSHp((char *)&saddr, len);
1822     RETURN;
1823
1824 nuts:
1825     if (dowarn)
1826         warn("accept() on closed fd");
1827     SETERRNO(EBADF,SS$_IVCHAN);
1828
1829 badexit:
1830     RETPUSHUNDEF;
1831
1832 #else
1833     DIE(no_sock_func, "accept");
1834 #endif
1835 }
1836
1837 PP(pp_shutdown)
1838 {
1839     dSP; dTARGET;
1840 #ifdef HAS_SOCKET
1841     int how = POPi;
1842     GV *gv = (GV*)POPs;
1843     register IO *io = GvIOn(gv);
1844
1845     if (!io || !IoIFP(io))
1846         goto nuts;
1847
1848     PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
1849     RETURN;
1850
1851 nuts:
1852     if (dowarn)
1853         warn("shutdown() on closed fd");
1854     SETERRNO(EBADF,SS$_IVCHAN);
1855     RETPUSHUNDEF;
1856 #else
1857     DIE(no_sock_func, "shutdown");
1858 #endif
1859 }
1860
1861 PP(pp_gsockopt)
1862 {
1863 #ifdef HAS_SOCKET
1864     return pp_ssockopt(ARGS);
1865 #else
1866     DIE(no_sock_func, "getsockopt");
1867 #endif
1868 }
1869
1870 PP(pp_ssockopt)
1871 {
1872     dSP;
1873 #ifdef HAS_SOCKET
1874     int optype = op->op_type;
1875     SV *sv;
1876     int fd;
1877     unsigned int optname;
1878     unsigned int lvl;
1879     GV *gv;
1880     register IO *io;
1881     Sock_size_t len;
1882
1883     if (optype == OP_GSOCKOPT)
1884         sv = sv_2mortal(NEWSV(22, 257));
1885     else
1886         sv = POPs;
1887     optname = (unsigned int) POPi;
1888     lvl = (unsigned int) POPi;
1889
1890     gv = (GV*)POPs;
1891     io = GvIOn(gv);
1892     if (!io || !IoIFP(io))
1893         goto nuts;
1894
1895     fd = PerlIO_fileno(IoIFP(io));
1896     switch (optype) {
1897     case OP_GSOCKOPT:
1898         SvGROW(sv, 257);
1899         (void)SvPOK_only(sv);
1900         SvCUR_set(sv,256);
1901         *SvEND(sv) ='\0';
1902         len = SvCUR(sv);
1903         if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
1904             goto nuts2;
1905         SvCUR_set(sv, len);
1906         *SvEND(sv) ='\0';
1907         PUSHs(sv);
1908         break;
1909     case OP_SSOCKOPT: {
1910             char *buf;
1911             int aint;
1912             if (SvPOKp(sv)) {
1913                 buf = SvPV(sv, na);
1914                 len = na;
1915             }
1916             else if (SvOK(sv)) {
1917                 aint = (int)SvIV(sv);
1918                 buf = (char*)&aint;
1919                 len = sizeof(int);
1920             }
1921             if (setsockopt(fd, lvl, optname, buf, len) < 0)
1922                 goto nuts2;
1923             PUSHs(&sv_yes);
1924         }
1925         break;
1926     }
1927     RETURN;
1928
1929 nuts:
1930     if (dowarn)
1931         warn("[gs]etsockopt() on closed fd");
1932     SETERRNO(EBADF,SS$_IVCHAN);
1933 nuts2:
1934     RETPUSHUNDEF;
1935
1936 #else
1937     DIE(no_sock_func, "setsockopt");
1938 #endif
1939 }
1940
1941 PP(pp_getsockname)
1942 {
1943 #ifdef HAS_SOCKET
1944     return pp_getpeername(ARGS);
1945 #else
1946     DIE(no_sock_func, "getsockname");
1947 #endif
1948 }
1949
1950 PP(pp_getpeername)
1951 {
1952     dSP;
1953 #ifdef HAS_SOCKET
1954     int optype = op->op_type;
1955     SV *sv;
1956     int fd;
1957     GV *gv = (GV*)POPs;
1958     register IO *io = GvIOn(gv);
1959     Sock_size_t len;
1960
1961     if (!io || !IoIFP(io))
1962         goto nuts;
1963
1964     sv = sv_2mortal(NEWSV(22, 257));
1965     (void)SvPOK_only(sv);
1966     len = 256;
1967     SvCUR_set(sv, len);
1968     *SvEND(sv) ='\0';
1969     fd = PerlIO_fileno(IoIFP(io));
1970     switch (optype) {
1971     case OP_GETSOCKNAME:
1972         if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
1973             goto nuts2;
1974         break;
1975     case OP_GETPEERNAME:
1976         if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
1977             goto nuts2;
1978         break;
1979     }
1980 #ifdef BOGUS_GETNAME_RETURN
1981     /* Interactive Unix, getpeername() and getsockname()
1982       does not return valid namelen */
1983     if (len == BOGUS_GETNAME_RETURN)
1984         len = sizeof(struct sockaddr);
1985 #endif
1986     SvCUR_set(sv, len);
1987     *SvEND(sv) ='\0';
1988     PUSHs(sv);
1989     RETURN;
1990
1991 nuts:
1992     if (dowarn)
1993         warn("get{sock, peer}name() on closed fd");
1994     SETERRNO(EBADF,SS$_IVCHAN);
1995 nuts2:
1996     RETPUSHUNDEF;
1997
1998 #else
1999     DIE(no_sock_func, "getpeername");
2000 #endif
2001 }
2002
2003 /* Stat calls. */
2004
2005 PP(pp_lstat)
2006 {
2007     return pp_stat(ARGS);
2008 }
2009
2010 PP(pp_stat)
2011 {
2012     dSP;
2013     GV *tmpgv;
2014     I32 gimme;
2015     I32 max = 13;
2016
2017     if (op->op_flags & OPf_REF) {
2018         tmpgv = cGVOP->op_gv;
2019       do_fstat:
2020         if (tmpgv != defgv) {
2021             laststype = OP_STAT;
2022             statgv = tmpgv;
2023             sv_setpv(statname, "");
2024             laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2025                 ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
2026         }
2027         if (laststatval < 0)
2028             max = 0;
2029     }
2030     else {
2031         SV* sv = POPs;
2032         if (SvTYPE(sv) == SVt_PVGV) {
2033             tmpgv = (GV*)sv;
2034             goto do_fstat;
2035         }
2036         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2037             tmpgv = (GV*)SvRV(sv);
2038             goto do_fstat;
2039         }
2040         sv_setpv(statname, SvPV(sv,na));
2041         statgv = Nullgv;
2042 #ifdef HAS_LSTAT
2043         laststype = op->op_type;
2044         if (op->op_type == OP_LSTAT)
2045             laststatval = lstat(SvPV(statname, na), &statcache);
2046         else
2047 #endif
2048             laststatval = Stat(SvPV(statname, na), &statcache);
2049         if (laststatval < 0) {
2050             if (dowarn && strchr(SvPV(statname, na), '\n'))
2051                 warn(warn_nl, "stat");
2052             max = 0;
2053         }
2054     }
2055
2056     gimme = GIMME_V;
2057     if (gimme != G_ARRAY) {
2058         if (gimme != G_VOID)
2059             XPUSHs(boolSV(max));
2060         RETURN;
2061     }
2062     if (max) {
2063         EXTEND(SP, max);
2064         EXTEND_MORTAL(max);
2065         PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2066         PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2067         PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2068         PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2069         PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2070         PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
2071 #ifdef USE_STAT_RDEV
2072         PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
2073 #else
2074         PUSHs(sv_2mortal(newSVpv("", 0)));
2075 #endif
2076         PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
2077 #ifdef BIG_TIME
2078         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2079         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2080         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2081 #else
2082         PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2083         PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2084         PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
2085 #endif
2086 #ifdef USE_STAT_BLOCKS
2087         PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2088         PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2089 #else
2090         PUSHs(sv_2mortal(newSVpv("", 0)));
2091         PUSHs(sv_2mortal(newSVpv("", 0)));
2092 #endif
2093     }
2094     RETURN;
2095 }
2096
2097 PP(pp_ftrread)
2098 {
2099     I32 result = my_stat(ARGS);
2100     dSP;
2101     if (result < 0)
2102         RETPUSHUNDEF;
2103     if (cando(S_IRUSR, 0, &statcache))
2104         RETPUSHYES;
2105     RETPUSHNO;
2106 }
2107
2108 PP(pp_ftrwrite)
2109 {
2110     I32 result = my_stat(ARGS);
2111     dSP;
2112     if (result < 0)
2113         RETPUSHUNDEF;
2114     if (cando(S_IWUSR, 0, &statcache))
2115         RETPUSHYES;
2116     RETPUSHNO;
2117 }
2118
2119 PP(pp_ftrexec)
2120 {
2121     I32 result = my_stat(ARGS);
2122     dSP;
2123     if (result < 0)
2124         RETPUSHUNDEF;
2125     if (cando(S_IXUSR, 0, &statcache))
2126         RETPUSHYES;
2127     RETPUSHNO;
2128 }
2129
2130 PP(pp_fteread)
2131 {
2132     I32 result = my_stat(ARGS);
2133     dSP;
2134     if (result < 0)
2135         RETPUSHUNDEF;
2136     if (cando(S_IRUSR, 1, &statcache))
2137         RETPUSHYES;
2138     RETPUSHNO;
2139 }
2140
2141 PP(pp_ftewrite)
2142 {
2143     I32 result = my_stat(ARGS);
2144     dSP;
2145     if (result < 0)
2146         RETPUSHUNDEF;
2147     if (cando(S_IWUSR, 1, &statcache))
2148         RETPUSHYES;
2149     RETPUSHNO;
2150 }
2151
2152 PP(pp_fteexec)
2153 {
2154     I32 result = my_stat(ARGS);
2155     dSP;
2156     if (result < 0)
2157         RETPUSHUNDEF;
2158     if (cando(S_IXUSR, 1, &statcache))
2159         RETPUSHYES;
2160     RETPUSHNO;
2161 }
2162
2163 PP(pp_ftis)
2164 {
2165     I32 result = my_stat(ARGS);
2166     dSP;
2167     if (result < 0)
2168         RETPUSHUNDEF;
2169     RETPUSHYES;
2170 }
2171
2172 PP(pp_fteowned)
2173 {
2174     return pp_ftrowned(ARGS);
2175 }
2176
2177 PP(pp_ftrowned)
2178 {
2179     I32 result = my_stat(ARGS);
2180     dSP;
2181     if (result < 0)
2182         RETPUSHUNDEF;
2183     if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2184         RETPUSHYES;
2185     RETPUSHNO;
2186 }
2187
2188 PP(pp_ftzero)
2189 {
2190     I32 result = my_stat(ARGS);
2191     dSP;
2192     if (result < 0)
2193         RETPUSHUNDEF;
2194     if (!statcache.st_size)
2195         RETPUSHYES;
2196     RETPUSHNO;
2197 }
2198
2199 PP(pp_ftsize)
2200 {
2201     I32 result = my_stat(ARGS);
2202     dSP; dTARGET;
2203     if (result < 0)
2204         RETPUSHUNDEF;
2205     PUSHi(statcache.st_size);
2206     RETURN;
2207 }
2208
2209 PP(pp_ftmtime)
2210 {
2211     I32 result = my_stat(ARGS);
2212     dSP; dTARGET;
2213     if (result < 0)
2214         RETPUSHUNDEF;
2215     PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
2216     RETURN;
2217 }
2218
2219 PP(pp_ftatime)
2220 {
2221     I32 result = my_stat(ARGS);
2222     dSP; dTARGET;
2223     if (result < 0)
2224         RETPUSHUNDEF;
2225     PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
2226     RETURN;
2227 }
2228
2229 PP(pp_ftctime)
2230 {
2231     I32 result = my_stat(ARGS);
2232     dSP; dTARGET;
2233     if (result < 0)
2234         RETPUSHUNDEF;
2235     PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
2236     RETURN;
2237 }
2238
2239 PP(pp_ftsock)
2240 {
2241     I32 result = my_stat(ARGS);
2242     dSP;
2243     if (result < 0)
2244         RETPUSHUNDEF;
2245     if (S_ISSOCK(statcache.st_mode))
2246         RETPUSHYES;
2247     RETPUSHNO;
2248 }
2249
2250 PP(pp_ftchr)
2251 {
2252     I32 result = my_stat(ARGS);
2253     dSP;
2254     if (result < 0)
2255         RETPUSHUNDEF;
2256     if (S_ISCHR(statcache.st_mode))
2257         RETPUSHYES;
2258     RETPUSHNO;
2259 }
2260
2261 PP(pp_ftblk)
2262 {
2263     I32 result = my_stat(ARGS);
2264     dSP;
2265     if (result < 0)
2266         RETPUSHUNDEF;
2267     if (S_ISBLK(statcache.st_mode))
2268         RETPUSHYES;
2269     RETPUSHNO;
2270 }
2271
2272 PP(pp_ftfile)
2273 {
2274     I32 result = my_stat(ARGS);
2275     dSP;
2276     if (result < 0)
2277         RETPUSHUNDEF;
2278     if (S_ISREG(statcache.st_mode))
2279         RETPUSHYES;
2280     RETPUSHNO;
2281 }
2282
2283 PP(pp_ftdir)
2284 {
2285     I32 result = my_stat(ARGS);
2286     dSP;
2287     if (result < 0)
2288         RETPUSHUNDEF;
2289     if (S_ISDIR(statcache.st_mode))
2290         RETPUSHYES;
2291     RETPUSHNO;
2292 }
2293
2294 PP(pp_ftpipe)
2295 {
2296     I32 result = my_stat(ARGS);
2297     dSP;
2298     if (result < 0)
2299         RETPUSHUNDEF;
2300     if (S_ISFIFO(statcache.st_mode))
2301         RETPUSHYES;
2302     RETPUSHNO;
2303 }
2304
2305 PP(pp_ftlink)
2306 {
2307     I32 result = my_lstat(ARGS);
2308     dSP;
2309     if (result < 0)
2310         RETPUSHUNDEF;
2311     if (S_ISLNK(statcache.st_mode))
2312         RETPUSHYES;
2313     RETPUSHNO;
2314 }
2315
2316 PP(pp_ftsuid)
2317 {
2318     dSP;
2319 #ifdef S_ISUID
2320     I32 result = my_stat(ARGS);
2321     SPAGAIN;
2322     if (result < 0)
2323         RETPUSHUNDEF;
2324     if (statcache.st_mode & S_ISUID)
2325         RETPUSHYES;
2326 #endif
2327     RETPUSHNO;
2328 }
2329
2330 PP(pp_ftsgid)
2331 {
2332     dSP;
2333 #ifdef S_ISGID
2334     I32 result = my_stat(ARGS);
2335     SPAGAIN;
2336     if (result < 0)
2337         RETPUSHUNDEF;
2338     if (statcache.st_mode & S_ISGID)
2339         RETPUSHYES;
2340 #endif
2341     RETPUSHNO;
2342 }
2343
2344 PP(pp_ftsvtx)
2345 {
2346     dSP;
2347 #ifdef S_ISVTX
2348     I32 result = my_stat(ARGS);
2349     SPAGAIN;
2350     if (result < 0)
2351         RETPUSHUNDEF;
2352     if (statcache.st_mode & S_ISVTX)
2353         RETPUSHYES;
2354 #endif
2355     RETPUSHNO;
2356 }
2357
2358 PP(pp_fttty)
2359 {
2360     dSP;
2361     int fd;
2362     GV *gv;
2363     char *tmps;
2364     if (op->op_flags & OPf_REF) {
2365         gv = cGVOP->op_gv;
2366         tmps = "";
2367     }
2368     else
2369         gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
2370     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2371         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2372     else if (isDIGIT(*tmps))
2373         fd = atoi(tmps);
2374     else
2375         RETPUSHUNDEF;
2376     if (isatty(fd))
2377         RETPUSHYES;
2378     RETPUSHNO;
2379 }
2380
2381 #if defined(atarist) /* this will work with atariST. Configure will
2382                         make guesses for other systems. */
2383 # define FILE_base(f) ((f)->_base)
2384 # define FILE_ptr(f) ((f)->_ptr)
2385 # define FILE_cnt(f) ((f)->_cnt)
2386 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2387 #endif
2388
2389 PP(pp_fttext)
2390 {
2391     dSP;
2392     I32 i;
2393     I32 len;
2394     I32 odd = 0;
2395     STDCHAR tbuf[512];
2396     register STDCHAR *s;
2397     register IO *io;
2398     register SV *sv;
2399     GV *gv;
2400
2401     if (op->op_flags & OPf_REF)
2402         gv = cGVOP->op_gv;
2403     else if (isGV(TOPs))
2404         gv = (GV*)POPs;
2405     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2406         gv = (GV*)SvRV(POPs);
2407     else
2408         gv = Nullgv;
2409
2410     if (gv) {
2411         EXTEND(SP, 1);
2412         if (gv == defgv) {
2413             if (statgv)
2414                 io = GvIO(statgv);
2415             else {
2416                 sv = statname;
2417                 goto really_filename;
2418             }
2419         }
2420         else {
2421             statgv = gv;
2422             laststatval = -1;
2423             sv_setpv(statname, "");
2424             io = GvIO(statgv);
2425         }
2426         if (io && IoIFP(io)) {
2427             if (! PerlIO_has_base(IoIFP(io)))
2428                 DIE("-T and -B not implemented on filehandles");
2429             laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
2430             if (laststatval < 0)
2431                 RETPUSHUNDEF;
2432             if (S_ISDIR(statcache.st_mode))     /* handle NFS glitch */
2433                 if (op->op_type == OP_FTTEXT)
2434                     RETPUSHNO;
2435                 else
2436                     RETPUSHYES;
2437             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2438                 i = PerlIO_getc(IoIFP(io));
2439                 if (i != EOF)
2440                     (void)PerlIO_ungetc(IoIFP(io),i);
2441             }
2442             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2443                 RETPUSHYES;
2444             len = PerlIO_get_bufsiz(IoIFP(io));
2445             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2446             /* sfio can have large buffers - limit to 512 */
2447             if (len > 512)
2448                 len = 512;
2449         }
2450         else {
2451             if (dowarn)
2452                 warn("Test on unopened file <%s>",
2453                   GvENAME(cGVOP->op_gv));
2454             SETERRNO(EBADF,RMS$_IFI);
2455             RETPUSHUNDEF;
2456         }
2457     }
2458     else {
2459         sv = POPs;
2460       really_filename:
2461         statgv = Nullgv;
2462         laststatval = -1;
2463         sv_setpv(statname, SvPV(sv, na));
2464 #ifdef HAS_OPEN3
2465         i = open(SvPV(sv, na), O_RDONLY, 0);
2466 #else
2467         i = open(SvPV(sv, na), 0);
2468 #endif
2469         if (i < 0) {
2470             if (dowarn && strchr(SvPV(sv, na), '\n'))
2471                 warn(warn_nl, "open");
2472             RETPUSHUNDEF;
2473         }
2474         laststatval = Fstat(i, &statcache);
2475         if (laststatval < 0)
2476             RETPUSHUNDEF;
2477         len = read(i, tbuf, 512);
2478         (void)close(i);
2479         if (len <= 0) {
2480             if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2481                 RETPUSHNO;              /* special case NFS directories */
2482             RETPUSHYES;         /* null file is anything */
2483         }
2484         s = tbuf;
2485     }
2486
2487     /* now scan s to look for textiness */
2488     /*   XXX ASCII dependent code */
2489
2490     for (i = 0; i < len; i++, s++) {
2491         if (!*s) {                      /* null never allowed in text */
2492             odd += len;
2493             break;
2494         }
2495         else if (*s & 128)
2496             odd++;
2497         else if (*s < 32 &&
2498           *s != '\n' && *s != '\r' && *s != '\b' &&
2499           *s != '\t' && *s != '\f' && *s != 27)
2500             odd++;
2501     }
2502
2503     if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2504         RETPUSHNO;
2505     else
2506         RETPUSHYES;
2507 }
2508
2509 PP(pp_ftbinary)
2510 {
2511     return pp_fttext(ARGS);
2512 }
2513
2514 /* File calls. */
2515
2516 PP(pp_chdir)
2517 {
2518     dSP; dTARGET;
2519     char *tmps;
2520     SV **svp;
2521
2522     if (MAXARG < 1)
2523         tmps = Nullch;
2524     else
2525         tmps = POPp;
2526     if (!tmps || !*tmps) {
2527         svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2528         if (svp)
2529             tmps = SvPV(*svp, na);
2530     }
2531     if (!tmps || !*tmps) {
2532         svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2533         if (svp)
2534             tmps = SvPV(*svp, na);
2535     }
2536     TAINT_PROPER("chdir");
2537     PUSHi( chdir(tmps) >= 0 );
2538 #ifdef VMS
2539     /* Clear the DEFAULT element of ENV so we'll get the new value
2540      * in the future. */
2541     hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
2542 #endif
2543     RETURN;
2544 }
2545
2546 PP(pp_chown)
2547 {
2548     dSP; dMARK; dTARGET;
2549     I32 value;
2550 #ifdef HAS_CHOWN
2551     value = (I32)apply(op->op_type, MARK, SP);
2552     SP = MARK;
2553     PUSHi(value);
2554     RETURN;
2555 #else
2556     DIE(no_func, "Unsupported function chown");
2557 #endif
2558 }
2559
2560 PP(pp_chroot)
2561 {
2562     dSP; dTARGET;
2563     char *tmps;
2564 #ifdef HAS_CHROOT
2565     tmps = POPp;
2566     TAINT_PROPER("chroot");
2567     PUSHi( chroot(tmps) >= 0 );
2568     RETURN;
2569 #else
2570     DIE(no_func, "chroot");
2571 #endif
2572 }
2573
2574 PP(pp_unlink)
2575 {
2576     dSP; dMARK; dTARGET;
2577     I32 value;
2578     value = (I32)apply(op->op_type, MARK, SP);
2579     SP = MARK;
2580     PUSHi(value);
2581     RETURN;
2582 }
2583
2584 PP(pp_chmod)
2585 {
2586     dSP; dMARK; dTARGET;
2587     I32 value;
2588     value = (I32)apply(op->op_type, MARK, SP);
2589     SP = MARK;
2590     PUSHi(value);
2591     RETURN;
2592 }
2593
2594 PP(pp_utime)
2595 {
2596     dSP; dMARK; dTARGET;
2597     I32 value;
2598     value = (I32)apply(op->op_type, MARK, SP);
2599     SP = MARK;
2600     PUSHi(value);
2601     RETURN;
2602 }
2603
2604 PP(pp_rename)
2605 {
2606     dSP; dTARGET;
2607     int anum;
2608
2609     char *tmps2 = POPp;
2610     char *tmps = SvPV(TOPs, na);
2611     TAINT_PROPER("rename");
2612 #ifdef HAS_RENAME
2613     anum = rename(tmps, tmps2);
2614 #else
2615     if (!(anum = Stat(tmps, &statbuf))) {
2616         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
2617             anum = 1;
2618         else {
2619             if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
2620                 (void)UNLINK(tmps2);
2621             if (!(anum = link(tmps, tmps2)))
2622                 anum = UNLINK(tmps);
2623         }
2624     }
2625 #endif
2626     SETi( anum >= 0 );
2627     RETURN;
2628 }
2629
2630 PP(pp_link)
2631 {
2632     dSP; dTARGET;
2633 #ifdef HAS_LINK
2634     char *tmps2 = POPp;
2635     char *tmps = SvPV(TOPs, na);
2636     TAINT_PROPER("link");
2637     SETi( link(tmps, tmps2) >= 0 );
2638 #else
2639     DIE(no_func, "Unsupported function link");
2640 #endif
2641     RETURN;
2642 }
2643
2644 PP(pp_symlink)
2645 {
2646     dSP; dTARGET;
2647 #ifdef HAS_SYMLINK
2648     char *tmps2 = POPp;
2649     char *tmps = SvPV(TOPs, na);
2650     TAINT_PROPER("symlink");
2651     SETi( symlink(tmps, tmps2) >= 0 );
2652     RETURN;
2653 #else
2654     DIE(no_func, "symlink");
2655 #endif
2656 }
2657
2658 PP(pp_readlink)
2659 {
2660     dSP; dTARGET;
2661 #ifdef HAS_SYMLINK
2662     char *tmps;
2663     char buf[MAXPATHLEN];
2664     int len;
2665
2666     tmps = POPp;
2667     len = readlink(tmps, buf, sizeof buf);
2668     EXTEND(SP, 1);
2669     if (len < 0)
2670         RETPUSHUNDEF;
2671     PUSHp(buf, len);
2672     RETURN;
2673 #else
2674     EXTEND(SP, 1);
2675     RETSETUNDEF;                /* just pretend it's a normal file */
2676 #endif
2677 }
2678
2679 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2680 static int
2681 dooneliner(cmd, filename)
2682 char *cmd;
2683 char *filename;
2684 {
2685     char *save_filename = filename;
2686     char *cmdline;
2687     char *s;
2688     PerlIO *myfp;
2689     int anum = 1;
2690
2691     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2692     strcpy(cmdline, cmd);
2693     strcat(cmdline, " ");
2694     for (s = cmdline + strlen(cmdline); *filename; ) {
2695         *s++ = '\\';
2696         *s++ = *filename++;
2697     }
2698     strcpy(s, " 2>&1");
2699     myfp = my_popen(cmdline, "r");
2700     Safefree(cmdline);
2701
2702     if (myfp) {
2703         SV *tmpsv = sv_newmortal();
2704         /* Need to save/restore 'rs' ?? */
2705         s = sv_gets(tmpsv, myfp, 0);
2706         (void)my_pclose(myfp);
2707         if (s != Nullch) {
2708             int e;
2709             for (e = 1;
2710 #ifdef HAS_SYS_ERRLIST
2711                  e <= sys_nerr
2712 #endif
2713                  ; e++)
2714             {
2715                 /* you don't see this */
2716                 char *errmsg =
2717 #ifdef HAS_SYS_ERRLIST
2718                     sys_errlist[e]
2719 #else
2720                     strerror(e)
2721 #endif
2722                     ;
2723                 if (!errmsg)
2724                     break;
2725                 if (instr(s, errmsg)) {
2726                     SETERRNO(e,0);
2727                     return 0;
2728                 }
2729             }
2730             SETERRNO(0,0);
2731 #ifndef EACCES
2732 #define EACCES EPERM
2733 #endif
2734             if (instr(s, "cannot make"))
2735                 SETERRNO(EEXIST,RMS$_FEX);
2736             else if (instr(s, "existing file"))
2737                 SETERRNO(EEXIST,RMS$_FEX);
2738             else if (instr(s, "ile exists"))
2739                 SETERRNO(EEXIST,RMS$_FEX);
2740             else if (instr(s, "non-exist"))
2741                 SETERRNO(ENOENT,RMS$_FNF);
2742             else if (instr(s, "does not exist"))
2743                 SETERRNO(ENOENT,RMS$_FNF);
2744             else if (instr(s, "not empty"))
2745                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
2746             else if (instr(s, "cannot access"))
2747                 SETERRNO(EACCES,RMS$_PRV);
2748             else
2749                 SETERRNO(EPERM,RMS$_PRV);
2750             return 0;
2751         }
2752         else {  /* some mkdirs return no failure indication */
2753             anum = (Stat(save_filename, &statbuf) >= 0);
2754             if (op->op_type == OP_RMDIR)
2755                 anum = !anum;
2756             if (anum)
2757                 SETERRNO(0,0);
2758             else
2759                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
2760         }
2761         return anum;
2762     }
2763     else
2764         return 0;
2765 }
2766 #endif
2767
2768 PP(pp_mkdir)
2769 {
2770     dSP; dTARGET;
2771     int mode = POPi;
2772 #ifndef HAS_MKDIR
2773     int oldumask;
2774 #endif
2775     char *tmps = SvPV(TOPs, na);
2776
2777     TAINT_PROPER("mkdir");
2778 #ifdef HAS_MKDIR
2779     SETi( Mkdir(tmps, mode) >= 0 );
2780 #else
2781     SETi( dooneliner("mkdir", tmps) );
2782     oldumask = umask(0);
2783     umask(oldumask);
2784     chmod(tmps, (mode & ~oldumask) & 0777);
2785 #endif
2786     RETURN;
2787 }
2788
2789 PP(pp_rmdir)
2790 {
2791     dSP; dTARGET;
2792     char *tmps;
2793
2794     tmps = POPp;
2795     TAINT_PROPER("rmdir");
2796 #ifdef HAS_RMDIR
2797     XPUSHi( rmdir(tmps) >= 0 );
2798 #else
2799     XPUSHi( dooneliner("rmdir", tmps) );
2800 #endif
2801     RETURN;
2802 }
2803
2804 /* Directory calls. */
2805
2806 PP(pp_open_dir)
2807 {
2808     dSP;
2809 #if defined(Direntry_t) && defined(HAS_READDIR)
2810     char *dirname = POPp;
2811     GV *gv = (GV*)POPs;
2812     register IO *io = GvIOn(gv);
2813
2814     if (!io)
2815         goto nope;
2816
2817     if (IoDIRP(io))
2818         closedir(IoDIRP(io));
2819     if (!(IoDIRP(io) = opendir(dirname)))
2820         goto nope;
2821
2822     RETPUSHYES;
2823 nope:
2824     if (!errno)
2825         SETERRNO(EBADF,RMS$_DIR);
2826     RETPUSHUNDEF;
2827 #else
2828     DIE(no_dir_func, "opendir");
2829 #endif
2830 }
2831
2832 PP(pp_readdir)
2833 {
2834     dSP;
2835 #if defined(Direntry_t) && defined(HAS_READDIR)
2836 #ifndef I_DIRENT
2837     Direntry_t *readdir _((DIR *));
2838 #endif
2839     register Direntry_t *dp;
2840     GV *gv = (GV*)POPs;
2841     register IO *io = GvIOn(gv);
2842
2843     if (!io || !IoDIRP(io))
2844         goto nope;
2845
2846     if (GIMME == G_ARRAY) {
2847         /*SUPPRESS 560*/
2848         while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
2849 #ifdef DIRNAMLEN
2850             XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
2851 #else
2852             XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
2853 #endif
2854         }
2855     }
2856     else {
2857         if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
2858             goto nope;
2859 #ifdef DIRNAMLEN
2860         XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
2861 #else
2862         XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
2863 #endif
2864     }
2865     RETURN;
2866
2867 nope:
2868     if (!errno)
2869         SETERRNO(EBADF,RMS$_ISI);
2870     if (GIMME == G_ARRAY)
2871         RETURN;
2872     else
2873         RETPUSHUNDEF;
2874 #else
2875     DIE(no_dir_func, "readdir");
2876 #endif
2877 }
2878
2879 PP(pp_telldir)
2880 {
2881     dSP; dTARGET;
2882 #if defined(HAS_TELLDIR) || defined(telldir)
2883 #if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE)
2884     long telldir _((DIR *));
2885 #endif
2886     GV *gv = (GV*)POPs;
2887     register IO *io = GvIOn(gv);
2888
2889     if (!io || !IoDIRP(io))
2890         goto nope;
2891
2892     PUSHi( telldir(IoDIRP(io)) );
2893     RETURN;
2894 nope:
2895     if (!errno)
2896         SETERRNO(EBADF,RMS$_ISI);
2897     RETPUSHUNDEF;
2898 #else
2899     DIE(no_dir_func, "telldir");
2900 #endif
2901 }
2902
2903 PP(pp_seekdir)
2904 {
2905     dSP;
2906 #if defined(HAS_SEEKDIR) || defined(seekdir)
2907     long along = POPl;
2908     GV *gv = (GV*)POPs;
2909     register IO *io = GvIOn(gv);
2910
2911     if (!io || !IoDIRP(io))
2912         goto nope;
2913
2914     (void)seekdir(IoDIRP(io), along);
2915
2916     RETPUSHYES;
2917 nope:
2918     if (!errno)
2919         SETERRNO(EBADF,RMS$_ISI);
2920     RETPUSHUNDEF;
2921 #else
2922     DIE(no_dir_func, "seekdir");
2923 #endif
2924 }
2925
2926 PP(pp_rewinddir)
2927 {
2928     dSP;
2929 #if defined(HAS_REWINDDIR) || defined(rewinddir)
2930     GV *gv = (GV*)POPs;
2931     register IO *io = GvIOn(gv);
2932
2933     if (!io || !IoDIRP(io))
2934         goto nope;
2935
2936     (void)rewinddir(IoDIRP(io));
2937     RETPUSHYES;
2938 nope:
2939     if (!errno)
2940         SETERRNO(EBADF,RMS$_ISI);
2941     RETPUSHUNDEF;
2942 #else
2943     DIE(no_dir_func, "rewinddir");
2944 #endif
2945 }
2946
2947 PP(pp_closedir)
2948 {
2949     dSP;
2950 #if defined(Direntry_t) && defined(HAS_READDIR)
2951     GV *gv = (GV*)POPs;
2952     register IO *io = GvIOn(gv);
2953
2954     if (!io || !IoDIRP(io))
2955         goto nope;
2956
2957 #ifdef VOID_CLOSEDIR
2958     closedir(IoDIRP(io));
2959 #else
2960     if (closedir(IoDIRP(io)) < 0) {
2961         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
2962         goto nope;
2963     }
2964 #endif
2965     IoDIRP(io) = 0;
2966
2967     RETPUSHYES;
2968 nope:
2969     if (!errno)
2970         SETERRNO(EBADF,RMS$_IFI);
2971     RETPUSHUNDEF;
2972 #else
2973     DIE(no_dir_func, "closedir");
2974 #endif
2975 }
2976
2977 /* Process control. */
2978
2979 PP(pp_fork)
2980 {
2981 #ifdef HAS_FORK
2982     dSP; dTARGET;
2983     int childpid;
2984     GV *tmpgv;
2985
2986     EXTEND(SP, 1);
2987     childpid = fork();
2988     if (childpid < 0)
2989         RETSETUNDEF;
2990     if (!childpid) {
2991         /*SUPPRESS 560*/
2992         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
2993             sv_setiv(GvSV(tmpgv), (IV)getpid());
2994         hv_clear(pidstatus);    /* no kids, so don't wait for 'em */
2995     }
2996     PUSHi(childpid);
2997     RETURN;
2998 #else
2999     DIE(no_func, "Unsupported function fork");
3000 #endif
3001 }
3002
3003 PP(pp_wait)
3004 {
3005 #if !defined(DOSISH) || defined(OS2)
3006     dSP; dTARGET;
3007     int childpid;
3008     int argflags;
3009
3010     childpid = wait4pid(-1, &argflags, 0);
3011     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3012     XPUSHi(childpid);
3013     RETURN;
3014 #else
3015     DIE(no_func, "Unsupported function wait");
3016 #endif
3017 }
3018
3019 PP(pp_waitpid)
3020 {
3021 #if !defined(DOSISH) || defined(OS2)
3022     dSP; dTARGET;
3023     int childpid;
3024     int optype;
3025     int argflags;
3026
3027     optype = POPi;
3028     childpid = TOPi;
3029     childpid = wait4pid(childpid, &argflags, optype);
3030     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3031     SETi(childpid);
3032     RETURN;
3033 #else
3034     DIE(no_func, "Unsupported function wait");
3035 #endif
3036 }
3037
3038 PP(pp_system)
3039 {
3040     dSP; dMARK; dORIGMARK; dTARGET;
3041     I32 value;
3042     int childpid;
3043     int result;
3044     int status;
3045     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3046
3047     if (SP - MARK == 1) {
3048         if (tainting) {
3049             char *junk = SvPV(TOPs, na);
3050             TAINT_ENV();
3051             TAINT_PROPER("system");
3052         }
3053     }
3054 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3055     while ((childpid = vfork()) == -1) {
3056         if (errno != EAGAIN) {
3057             value = -1;
3058             SP = ORIGMARK;
3059             PUSHi(value);
3060             RETURN;
3061         }
3062         sleep(5);
3063     }
3064     if (childpid > 0) {
3065         rsignal_save(SIGINT, SIG_IGN, &ihand);
3066         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3067         do {
3068             result = wait4pid(childpid, &status, 0);
3069         } while (result == -1 && errno == EINTR);
3070         (void)rsignal_restore(SIGINT, &ihand);
3071         (void)rsignal_restore(SIGQUIT, &qhand);
3072         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3073         do_execfree();  /* free any memory child malloced on vfork */
3074         SP = ORIGMARK;
3075         PUSHi(STATUS_CURRENT);
3076         RETURN;
3077     }
3078     if (op->op_flags & OPf_STACKED) {
3079         SV *really = *++MARK;
3080         value = (I32)do_aexec(really, MARK, SP);
3081     }
3082     else if (SP - MARK != 1)
3083         value = (I32)do_aexec(Nullsv, MARK, SP);
3084     else {
3085         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3086     }
3087     _exit(-1);
3088 #else /* ! FORK or VMS or OS/2 */
3089     if (op->op_flags & OPf_STACKED) {
3090         SV *really = *++MARK;
3091         value = (I32)do_aspawn(really, MARK, SP);
3092     }
3093     else if (SP - MARK != 1)
3094         value = (I32)do_aspawn(Nullsv, MARK, SP);
3095     else {
3096         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3097     }
3098     STATUS_NATIVE_SET(value);
3099     do_execfree();
3100     SP = ORIGMARK;
3101     PUSHi(STATUS_CURRENT);
3102 #endif /* !FORK or VMS */
3103     RETURN;
3104 }
3105
3106 PP(pp_exec)
3107 {
3108     dSP; dMARK; dORIGMARK; dTARGET;
3109     I32 value;
3110
3111     if (op->op_flags & OPf_STACKED) {
3112         SV *really = *++MARK;
3113         value = (I32)do_aexec(really, MARK, SP);
3114     }
3115     else if (SP - MARK != 1)
3116 #ifdef VMS
3117         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3118 #else
3119         value = (I32)do_aexec(Nullsv, MARK, SP);
3120 #endif
3121     else {
3122         if (tainting) {
3123             char *junk = SvPV(*SP, na);
3124             TAINT_ENV();
3125             TAINT_PROPER("exec");
3126         }
3127 #ifdef VMS
3128         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3129 #else
3130         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3131 #endif
3132     }
3133     SP = ORIGMARK;
3134     PUSHi(value);
3135     RETURN;
3136 }
3137
3138 PP(pp_kill)
3139 {
3140     dSP; dMARK; dTARGET;
3141     I32 value;
3142 #ifdef HAS_KILL
3143     value = (I32)apply(op->op_type, MARK, SP);
3144     SP = MARK;
3145     PUSHi(value);
3146     RETURN;
3147 #else
3148     DIE(no_func, "Unsupported function kill");
3149 #endif
3150 }
3151
3152 PP(pp_getppid)
3153 {
3154 #ifdef HAS_GETPPID
3155     dSP; dTARGET;
3156     XPUSHi( getppid() );
3157     RETURN;
3158 #else
3159     DIE(no_func, "getppid");
3160 #endif
3161 }
3162
3163 PP(pp_getpgrp)
3164 {
3165 #ifdef HAS_GETPGRP
3166     dSP; dTARGET;
3167     int pid;
3168     I32 value;
3169
3170     if (MAXARG < 1)
3171         pid = 0;
3172     else
3173         pid = SvIVx(POPs);
3174 #ifdef BSD_GETPGRP
3175     value = (I32)BSD_GETPGRP(pid);
3176 #else
3177     if (pid != 0 && pid != getpid())
3178         DIE("POSIX getpgrp can't take an argument");
3179     value = (I32)getpgrp();
3180 #endif
3181     XPUSHi(value);
3182     RETURN;
3183 #else
3184     DIE(no_func, "getpgrp()");
3185 #endif
3186 }
3187
3188 PP(pp_setpgrp)
3189 {
3190 #ifdef HAS_SETPGRP
3191     dSP; dTARGET;
3192     int pgrp;
3193     int pid;
3194     if (MAXARG < 2) {
3195         pgrp = 0;
3196         pid = 0;
3197     }
3198     else {
3199         pgrp = POPi;
3200         pid = TOPi;
3201     }
3202
3203     TAINT_PROPER("setpgrp");
3204 #ifdef BSD_SETPGRP
3205     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3206 #else
3207     if ((pgrp != 0 && pgrp != getpid())) || (pid != 0 && pid != getpid()))
3208         DIE("POSIX setpgrp can't take an argument");
3209     SETi( setpgrp() >= 0 );
3210 #endif /* USE_BSDPGRP */
3211     RETURN;
3212 #else
3213     DIE(no_func, "setpgrp()");
3214 #endif
3215 }
3216
3217 PP(pp_getpriority)
3218 {
3219     dSP; dTARGET;
3220     int which;
3221     int who;
3222 #ifdef HAS_GETPRIORITY
3223     who = POPi;
3224     which = TOPi;
3225     SETi( getpriority(which, who) );
3226     RETURN;
3227 #else
3228     DIE(no_func, "getpriority()");
3229 #endif
3230 }
3231
3232 PP(pp_setpriority)
3233 {
3234     dSP; dTARGET;
3235     int which;
3236     int who;
3237     int niceval;
3238 #ifdef HAS_SETPRIORITY
3239     niceval = POPi;
3240     who = POPi;
3241     which = TOPi;
3242     TAINT_PROPER("setpriority");
3243     SETi( setpriority(which, who, niceval) >= 0 );
3244     RETURN;
3245 #else
3246     DIE(no_func, "setpriority()");
3247 #endif
3248 }
3249
3250 /* Time calls. */
3251
3252 PP(pp_time)
3253 {
3254     dSP; dTARGET;
3255 #ifdef BIG_TIME
3256     XPUSHn( time(Null(Time_t*)) );
3257 #else
3258     XPUSHi( time(Null(Time_t*)) );
3259 #endif
3260     RETURN;
3261 }
3262
3263 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3264    to HZ.  Probably.  For now, assume that if the system
3265    defines HZ, it does so correctly.  (Will this break
3266    on VMS?)
3267    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3268    it's supported.    --AD  9/96.
3269 */
3270
3271 #ifndef HZ
3272 #  ifdef CLK_TCK
3273 #    define HZ CLK_TCK
3274 #  else
3275 #    define HZ 60
3276 #  endif
3277 #endif
3278
3279 PP(pp_tms)
3280 {
3281     dSP;
3282
3283 #ifndef HAS_TIMES
3284     DIE("times not implemented");
3285 #else
3286     EXTEND(SP, 4);
3287
3288 #ifndef VMS
3289     (void)times(&timesbuf);
3290 #else
3291     (void)times((tbuffer_t *)&timesbuf);  /* time.h uses different name for */
3292                                           /* struct tms, though same data   */
3293                                           /* is returned.                   */
3294 #endif
3295
3296     PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3297     if (GIMME == G_ARRAY) {
3298         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3299         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3300         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3301     }
3302     RETURN;
3303 #endif /* HAS_TIMES */
3304 }
3305
3306 PP(pp_localtime)
3307 {
3308     return pp_gmtime(ARGS);
3309 }
3310
3311 PP(pp_gmtime)
3312 {
3313     dSP;
3314     Time_t when;
3315     struct tm *tmbuf;
3316     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3317     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3318                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3319
3320     if (MAXARG < 1)
3321         (void)time(&when);
3322     else
3323 #ifdef BIG_TIME
3324         when = (Time_t)SvNVx(POPs);
3325 #else
3326         when = (Time_t)SvIVx(POPs);
3327 #endif
3328
3329     if (op->op_type == OP_LOCALTIME)
3330         tmbuf = localtime(&when);
3331     else
3332         tmbuf = gmtime(&when);
3333
3334     EXTEND(SP, 9);
3335     EXTEND_MORTAL(9);
3336     if (GIMME != G_ARRAY) {
3337         dTARGET;
3338         SV *tsv;
3339         if (!tmbuf)
3340             RETPUSHUNDEF;
3341         tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3342                        dayname[tmbuf->tm_wday],
3343                        monname[tmbuf->tm_mon],
3344                        tmbuf->tm_mday,
3345                        tmbuf->tm_hour,
3346                        tmbuf->tm_min,
3347                        tmbuf->tm_sec,
3348                        tmbuf->tm_year + 1900);
3349         PUSHs(sv_2mortal(tsv));
3350     }
3351     else if (tmbuf) {
3352         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3353         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3354         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3355         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3356         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3357         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3358         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3359         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3360         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3361     }
3362     RETURN;
3363 }
3364
3365 PP(pp_alarm)
3366 {
3367     dSP; dTARGET;
3368     int anum;
3369 #ifdef HAS_ALARM
3370     anum = POPi;
3371     anum = alarm((unsigned int)anum);
3372     EXTEND(SP, 1);
3373     if (anum < 0)
3374         RETPUSHUNDEF;
3375     PUSHi((I32)anum);
3376     RETURN;
3377 #else
3378     DIE(no_func, "Unsupported function alarm");
3379 #endif
3380 }
3381
3382 PP(pp_sleep)
3383 {
3384     dSP; dTARGET;
3385     I32 duration;
3386     Time_t lasttime;
3387     Time_t when;
3388
3389     (void)time(&lasttime);
3390     if (MAXARG < 1)
3391         Pause();
3392     else {
3393         duration = POPi;
3394         sleep((unsigned int)duration);
3395     }
3396     (void)time(&when);
3397     XPUSHi(when - lasttime);
3398     RETURN;
3399 }
3400
3401 /* Shared memory. */
3402
3403 PP(pp_shmget)
3404 {
3405     return pp_semget(ARGS);
3406 }
3407
3408 PP(pp_shmctl)
3409 {
3410     return pp_semctl(ARGS);
3411 }
3412
3413 PP(pp_shmread)
3414 {
3415     return pp_shmwrite(ARGS);
3416 }
3417
3418 PP(pp_shmwrite)
3419 {
3420 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3421     dSP; dMARK; dTARGET;
3422     I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3423     SP = MARK;
3424     PUSHi(value);
3425     RETURN;
3426 #else
3427     return pp_semget(ARGS);
3428 #endif
3429 }
3430
3431 /* Message passing. */
3432
3433 PP(pp_msgget)
3434 {
3435     return pp_semget(ARGS);
3436 }
3437
3438 PP(pp_msgctl)
3439 {
3440     return pp_semctl(ARGS);
3441 }
3442
3443 PP(pp_msgsnd)
3444 {
3445 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3446     dSP; dMARK; dTARGET;
3447     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3448     SP = MARK;
3449     PUSHi(value);
3450     RETURN;
3451 #else
3452     return pp_semget(ARGS);
3453 #endif
3454 }
3455
3456 PP(pp_msgrcv)
3457 {
3458 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3459     dSP; dMARK; dTARGET;
3460     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3461     SP = MARK;
3462     PUSHi(value);
3463     RETURN;
3464 #else
3465     return pp_semget(ARGS);
3466 #endif
3467 }
3468
3469 /* Semaphores. */
3470
3471 PP(pp_semget)
3472 {
3473 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3474     dSP; dMARK; dTARGET;
3475     int anum = do_ipcget(op->op_type, MARK, SP);
3476     SP = MARK;
3477     if (anum == -1)
3478         RETPUSHUNDEF;
3479     PUSHi(anum);
3480     RETURN;
3481 #else
3482     DIE("System V IPC is not implemented on this machine");
3483 #endif
3484 }
3485
3486 PP(pp_semctl)
3487 {
3488 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3489     dSP; dMARK; dTARGET;
3490     int anum = do_ipcctl(op->op_type, MARK, SP);
3491     SP = MARK;
3492     if (anum == -1)
3493         RETSETUNDEF;
3494     if (anum != 0) {
3495         PUSHi(anum);
3496     }
3497     else {
3498         PUSHp(zero_but_true, ZBTLEN);
3499     }
3500     RETURN;
3501 #else
3502     return pp_semget(ARGS);
3503 #endif
3504 }
3505
3506 PP(pp_semop)
3507 {
3508 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3509     dSP; dMARK; dTARGET;
3510     I32 value = (I32)(do_semop(MARK, SP) >= 0);
3511     SP = MARK;
3512     PUSHi(value);
3513     RETURN;
3514 #else
3515     return pp_semget(ARGS);
3516 #endif
3517 }
3518
3519 /* Get system info. */
3520
3521 PP(pp_ghbyname)
3522 {
3523 #ifdef HAS_SOCKET
3524     return pp_ghostent(ARGS);
3525 #else
3526     DIE(no_sock_func, "gethostbyname");
3527 #endif
3528 }
3529
3530 PP(pp_ghbyaddr)
3531 {
3532 #ifdef HAS_SOCKET
3533     return pp_ghostent(ARGS);
3534 #else
3535     DIE(no_sock_func, "gethostbyaddr");
3536 #endif
3537 }
3538
3539 PP(pp_ghostent)
3540 {
3541     dSP;
3542 #ifdef HAS_SOCKET
3543     I32 which = op->op_type;
3544     register char **elem;
3545     register SV *sv;
3546     struct hostent *gethostbyname();
3547     struct hostent *gethostbyaddr();
3548 #ifdef HAS_GETHOSTENT
3549     struct hostent *gethostent();
3550 #endif
3551     struct hostent *hent;
3552     unsigned long len;
3553
3554     EXTEND(SP, 10);
3555     if (which == OP_GHBYNAME) {
3556         hent = gethostbyname(POPp);
3557     }
3558     else if (which == OP_GHBYADDR) {
3559         int addrtype = POPi;
3560         SV *addrsv = POPs;
3561         STRLEN addrlen;
3562         char *addr = SvPV(addrsv, addrlen);
3563
3564         hent = gethostbyaddr(addr, addrlen, addrtype);
3565     }
3566     else
3567 #ifdef HAS_GETHOSTENT
3568         hent = gethostent();
3569 #else
3570         DIE("gethostent not implemented");
3571 #endif
3572
3573 #ifdef HOST_NOT_FOUND
3574     if (!hent)
3575         STATUS_NATIVE_SET(h_errno);
3576 #endif
3577
3578     if (GIMME != G_ARRAY) {
3579         PUSHs(sv = sv_newmortal());
3580         if (hent) {
3581             if (which == OP_GHBYNAME) {
3582                 if (hent->h_addr)
3583                     sv_setpvn(sv, hent->h_addr, hent->h_length);
3584             }
3585             else
3586                 sv_setpv(sv, (char*)hent->h_name);
3587         }
3588         RETURN;
3589     }
3590
3591     if (hent) {
3592         PUSHs(sv = sv_mortalcopy(&sv_no));
3593         sv_setpv(sv, (char*)hent->h_name);
3594         PUSHs(sv = sv_mortalcopy(&sv_no));
3595         for (elem = hent->h_aliases; elem && *elem; elem++) {
3596             sv_catpv(sv, *elem);
3597             if (elem[1])
3598                 sv_catpvn(sv, " ", 1);
3599         }
3600         PUSHs(sv = sv_mortalcopy(&sv_no));
3601         sv_setiv(sv, (IV)hent->h_addrtype);
3602         PUSHs(sv = sv_mortalcopy(&sv_no));
3603         len = hent->h_length;
3604         sv_setiv(sv, (IV)len);
3605 #ifdef h_addr
3606         for (elem = hent->h_addr_list; elem && *elem; elem++) {
3607             XPUSHs(sv = sv_mortalcopy(&sv_no));
3608             sv_setpvn(sv, *elem, len);
3609         }
3610 #else
3611         PUSHs(sv = sv_mortalcopy(&sv_no));
3612         if (hent->h_addr)
3613             sv_setpvn(sv, hent->h_addr, len);
3614 #endif /* h_addr */
3615     }
3616     RETURN;
3617 #else
3618     DIE(no_sock_func, "gethostent");
3619 #endif
3620 }
3621
3622 PP(pp_gnbyname)
3623 {
3624 #ifdef HAS_SOCKET
3625     return pp_gnetent(ARGS);
3626 #else
3627     DIE(no_sock_func, "getnetbyname");
3628 #endif
3629 }
3630
3631 PP(pp_gnbyaddr)
3632 {
3633 #ifdef HAS_SOCKET
3634     return pp_gnetent(ARGS);
3635 #else
3636     DIE(no_sock_func, "getnetbyaddr");
3637 #endif
3638 }
3639
3640 PP(pp_gnetent)
3641 {
3642     dSP;
3643 #ifdef HAS_SOCKET
3644     I32 which = op->op_type;
3645     register char **elem;
3646     register SV *sv;
3647     struct netent *getnetbyname();
3648     struct netent *getnetbyaddr();
3649     struct netent *getnetent();
3650     struct netent *nent;
3651
3652     if (which == OP_GNBYNAME)
3653         nent = getnetbyname(POPp);
3654     else if (which == OP_GNBYADDR) {
3655         int addrtype = POPi;
3656         unsigned long addr = U_L(POPn);
3657         nent = getnetbyaddr((long)addr, addrtype);
3658     }
3659     else
3660         nent = getnetent();
3661
3662     EXTEND(SP, 4);
3663     if (GIMME != G_ARRAY) {
3664         PUSHs(sv = sv_newmortal());
3665         if (nent) {
3666             if (which == OP_GNBYNAME)
3667                 sv_setiv(sv, (IV)nent->n_net);
3668             else
3669                 sv_setpv(sv, nent->n_name);
3670         }
3671         RETURN;
3672     }
3673
3674     if (nent) {
3675         PUSHs(sv = sv_mortalcopy(&sv_no));
3676         sv_setpv(sv, nent->n_name);
3677         PUSHs(sv = sv_mortalcopy(&sv_no));
3678         for (elem = nent->n_aliases; *elem; elem++) {
3679             sv_catpv(sv, *elem);
3680             if (elem[1])
3681                 sv_catpvn(sv, " ", 1);
3682         }
3683         PUSHs(sv = sv_mortalcopy(&sv_no));
3684         sv_setiv(sv, (IV)nent->n_addrtype);
3685         PUSHs(sv = sv_mortalcopy(&sv_no));
3686         sv_setiv(sv, (IV)nent->n_net);
3687     }
3688
3689     RETURN;
3690 #else
3691     DIE(no_sock_func, "getnetent");
3692 #endif
3693 }
3694
3695 PP(pp_gpbyname)
3696 {
3697 #ifdef HAS_SOCKET
3698     return pp_gprotoent(ARGS);
3699 #else
3700     DIE(no_sock_func, "getprotobyname");
3701 #endif
3702 }
3703
3704 PP(pp_gpbynumber)
3705 {
3706 #ifdef HAS_SOCKET
3707     return pp_gprotoent(ARGS);
3708 #else
3709     DIE(no_sock_func, "getprotobynumber");
3710 #endif
3711 }
3712
3713 PP(pp_gprotoent)
3714 {
3715     dSP;
3716 #ifdef HAS_SOCKET
3717     I32 which = op->op_type;
3718     register char **elem;
3719     register SV *sv;
3720     struct protoent *getprotobyname();
3721     struct protoent *getprotobynumber();
3722     struct protoent *getprotoent();
3723     struct protoent *pent;
3724
3725     if (which == OP_GPBYNAME)
3726         pent = getprotobyname(POPp);
3727     else if (which == OP_GPBYNUMBER)
3728         pent = getprotobynumber(POPi);
3729     else
3730         pent = getprotoent();
3731
3732     EXTEND(SP, 3);
3733     if (GIMME != G_ARRAY) {
3734         PUSHs(sv = sv_newmortal());
3735         if (pent) {
3736             if (which == OP_GPBYNAME)
3737                 sv_setiv(sv, (IV)pent->p_proto);
3738             else
3739                 sv_setpv(sv, pent->p_name);
3740         }
3741         RETURN;
3742     }
3743
3744     if (pent) {
3745         PUSHs(sv = sv_mortalcopy(&sv_no));
3746         sv_setpv(sv, pent->p_name);
3747         PUSHs(sv = sv_mortalcopy(&sv_no));
3748         for (elem = pent->p_aliases; *elem; elem++) {
3749             sv_catpv(sv, *elem);
3750             if (elem[1])
3751                 sv_catpvn(sv, " ", 1);
3752         }
3753         PUSHs(sv = sv_mortalcopy(&sv_no));
3754         sv_setiv(sv, (IV)pent->p_proto);
3755     }
3756
3757     RETURN;
3758 #else
3759     DIE(no_sock_func, "getprotoent");
3760 #endif
3761 }
3762
3763 PP(pp_gsbyname)
3764 {
3765 #ifdef HAS_SOCKET
3766     return pp_gservent(ARGS);
3767 #else
3768     DIE(no_sock_func, "getservbyname");
3769 #endif
3770 }
3771
3772 PP(pp_gsbyport)
3773 {
3774 #ifdef HAS_SOCKET
3775     return pp_gservent(ARGS);
3776 #else
3777     DIE(no_sock_func, "getservbyport");
3778 #endif
3779 }
3780
3781 PP(pp_gservent)
3782 {
3783     dSP;
3784 #ifdef HAS_SOCKET
3785     I32 which = op->op_type;
3786     register char **elem;
3787     register SV *sv;
3788     struct servent *getservbyname();
3789     struct servent *getservbynumber();
3790     struct servent *getservent();
3791     struct servent *sent;
3792
3793     if (which == OP_GSBYNAME) {
3794         char *proto = POPp;
3795         char *name = POPp;
3796
3797         if (proto && !*proto)
3798             proto = Nullch;
3799
3800         sent = getservbyname(name, proto);
3801     }
3802     else if (which == OP_GSBYPORT) {
3803         char *proto = POPp;
3804         unsigned short port = POPu;
3805
3806 #ifdef HAS_HTONS
3807         port = htons(port);
3808 #endif
3809         sent = getservbyport(port, proto);
3810     }
3811     else
3812         sent = getservent();
3813
3814     EXTEND(SP, 4);
3815     if (GIMME != G_ARRAY) {
3816         PUSHs(sv = sv_newmortal());
3817         if (sent) {
3818             if (which == OP_GSBYNAME) {
3819 #ifdef HAS_NTOHS
3820                 sv_setiv(sv, (IV)ntohs(sent->s_port));
3821 #else
3822                 sv_setiv(sv, (IV)(sent->s_port));
3823 #endif
3824             }
3825             else
3826                 sv_setpv(sv, sent->s_name);
3827         }
3828         RETURN;
3829     }
3830
3831     if (sent) {
3832         PUSHs(sv = sv_mortalcopy(&sv_no));
3833         sv_setpv(sv, sent->s_name);
3834         PUSHs(sv = sv_mortalcopy(&sv_no));
3835         for (elem = sent->s_aliases; *elem; elem++) {
3836             sv_catpv(sv, *elem);
3837             if (elem[1])
3838                 sv_catpvn(sv, " ", 1);
3839         }
3840         PUSHs(sv = sv_mortalcopy(&sv_no));
3841 #ifdef HAS_NTOHS
3842         sv_setiv(sv, (IV)ntohs(sent->s_port));
3843 #else
3844         sv_setiv(sv, (IV)(sent->s_port));
3845 #endif
3846         PUSHs(sv = sv_mortalcopy(&sv_no));
3847         sv_setpv(sv, sent->s_proto);
3848     }
3849
3850     RETURN;
3851 #else
3852     DIE(no_sock_func, "getservent");
3853 #endif
3854 }
3855
3856 PP(pp_shostent)
3857 {
3858     dSP;
3859 #ifdef HAS_SOCKET
3860     sethostent(TOPi);
3861     RETSETYES;
3862 #else
3863     DIE(no_sock_func, "sethostent");
3864 #endif
3865 }
3866
3867 PP(pp_snetent)
3868 {
3869     dSP;
3870 #ifdef HAS_SOCKET
3871     setnetent(TOPi);
3872     RETSETYES;
3873 #else
3874     DIE(no_sock_func, "setnetent");
3875 #endif
3876 }
3877
3878 PP(pp_sprotoent)
3879 {
3880     dSP;
3881 #ifdef HAS_SOCKET
3882     setprotoent(TOPi);
3883     RETSETYES;
3884 #else
3885     DIE(no_sock_func, "setprotoent");
3886 #endif
3887 }
3888
3889 PP(pp_sservent)
3890 {
3891     dSP;
3892 #ifdef HAS_SOCKET
3893     setservent(TOPi);
3894     RETSETYES;
3895 #else
3896     DIE(no_sock_func, "setservent");
3897 #endif
3898 }
3899
3900 PP(pp_ehostent)
3901 {
3902     dSP;
3903 #ifdef HAS_SOCKET
3904     endhostent();
3905     EXTEND(sp,1);
3906     RETPUSHYES;
3907 #else
3908     DIE(no_sock_func, "endhostent");
3909 #endif
3910 }
3911
3912 PP(pp_enetent)
3913 {
3914     dSP;
3915 #ifdef HAS_SOCKET
3916     endnetent();
3917     EXTEND(sp,1);
3918     RETPUSHYES;
3919 #else
3920     DIE(no_sock_func, "endnetent");
3921 #endif
3922 }
3923
3924 PP(pp_eprotoent)
3925 {
3926     dSP;
3927 #ifdef HAS_SOCKET
3928     endprotoent();
3929     EXTEND(sp,1);
3930     RETPUSHYES;
3931 #else
3932     DIE(no_sock_func, "endprotoent");
3933 #endif
3934 }
3935
3936 PP(pp_eservent)
3937 {
3938     dSP;
3939 #ifdef HAS_SOCKET
3940     endservent();
3941     EXTEND(sp,1);
3942     RETPUSHYES;
3943 #else
3944     DIE(no_sock_func, "endservent");
3945 #endif
3946 }
3947
3948 PP(pp_gpwnam)
3949 {
3950 #ifdef HAS_PASSWD
3951     return pp_gpwent(ARGS);
3952 #else
3953     DIE(no_func, "getpwnam");
3954 #endif
3955 }
3956
3957 PP(pp_gpwuid)
3958 {
3959 #ifdef HAS_PASSWD
3960     return pp_gpwent(ARGS);
3961 #else
3962     DIE(no_func, "getpwuid");
3963 #endif
3964 }
3965
3966 PP(pp_gpwent)
3967 {
3968     dSP;
3969 #ifdef HAS_PASSWD
3970     I32 which = op->op_type;
3971     register SV *sv;
3972     struct passwd *pwent;
3973
3974     if (which == OP_GPWNAM)
3975         pwent = getpwnam(POPp);
3976     else if (which == OP_GPWUID)
3977         pwent = getpwuid(POPi);
3978     else
3979         pwent = (struct passwd *)getpwent();
3980
3981     EXTEND(SP, 10);
3982     if (GIMME != G_ARRAY) {
3983         PUSHs(sv = sv_newmortal());
3984         if (pwent) {
3985             if (which == OP_GPWNAM)
3986                 sv_setiv(sv, (IV)pwent->pw_uid);
3987             else
3988                 sv_setpv(sv, pwent->pw_name);
3989         }
3990         RETURN;
3991     }
3992
3993     if (pwent) {
3994         PUSHs(sv = sv_mortalcopy(&sv_no));
3995         sv_setpv(sv, pwent->pw_name);
3996         PUSHs(sv = sv_mortalcopy(&sv_no));
3997         sv_setpv(sv, pwent->pw_passwd);
3998         PUSHs(sv = sv_mortalcopy(&sv_no));
3999         sv_setiv(sv, (IV)pwent->pw_uid);
4000         PUSHs(sv = sv_mortalcopy(&sv_no));
4001         sv_setiv(sv, (IV)pwent->pw_gid);
4002         PUSHs(sv = sv_mortalcopy(&sv_no));
4003 #ifdef PWCHANGE
4004         sv_setiv(sv, (IV)pwent->pw_change);
4005 #else
4006 #ifdef PWQUOTA
4007         sv_setiv(sv, (IV)pwent->pw_quota);
4008 #else
4009 #ifdef PWAGE
4010         sv_setpv(sv, pwent->pw_age);
4011 #endif
4012 #endif
4013 #endif
4014         PUSHs(sv = sv_mortalcopy(&sv_no));
4015 #ifdef PWCLASS
4016         sv_setpv(sv, pwent->pw_class);
4017 #else
4018 #ifdef PWCOMMENT
4019         sv_setpv(sv, pwent->pw_comment);
4020 #endif
4021 #endif
4022         PUSHs(sv = sv_mortalcopy(&sv_no));
4023         sv_setpv(sv, pwent->pw_gecos);
4024         PUSHs(sv = sv_mortalcopy(&sv_no));
4025         sv_setpv(sv, pwent->pw_dir);
4026         PUSHs(sv = sv_mortalcopy(&sv_no));
4027         sv_setpv(sv, pwent->pw_shell);
4028 #ifdef PWEXPIRE
4029         PUSHs(sv = sv_mortalcopy(&sv_no));
4030         sv_setiv(sv, (IV)pwent->pw_expire);
4031 #endif
4032     }
4033     RETURN;
4034 #else
4035     DIE(no_func, "getpwent");
4036 #endif
4037 }
4038
4039 PP(pp_spwent)
4040 {
4041     dSP;
4042 #if defined(HAS_PASSWD) && !defined(CYGWIN32)
4043     setpwent();
4044     RETPUSHYES;
4045 #else
4046     DIE(no_func, "setpwent");
4047 #endif
4048 }
4049
4050 PP(pp_epwent)
4051 {
4052     dSP;
4053 #ifdef HAS_PASSWD
4054     endpwent();
4055     RETPUSHYES;
4056 #else
4057     DIE(no_func, "endpwent");
4058 #endif
4059 }
4060
4061 PP(pp_ggrnam)
4062 {
4063 #ifdef HAS_GROUP
4064     return pp_ggrent(ARGS);
4065 #else
4066     DIE(no_func, "getgrnam");
4067 #endif
4068 }
4069
4070 PP(pp_ggrgid)
4071 {
4072 #ifdef HAS_GROUP
4073     return pp_ggrent(ARGS);
4074 #else
4075     DIE(no_func, "getgrgid");
4076 #endif
4077 }
4078
4079 PP(pp_ggrent)
4080 {
4081     dSP;
4082 #ifdef HAS_GROUP
4083     I32 which = op->op_type;
4084     register char **elem;
4085     register SV *sv;
4086     struct group *grent;
4087
4088     if (which == OP_GGRNAM)
4089         grent = (struct group *)getgrnam(POPp);
4090     else if (which == OP_GGRGID)
4091         grent = (struct group *)getgrgid(POPi);
4092     else
4093         grent = (struct group *)getgrent();
4094
4095     EXTEND(SP, 4);
4096     if (GIMME != G_ARRAY) {
4097         PUSHs(sv = sv_newmortal());
4098         if (grent) {
4099             if (which == OP_GGRNAM)
4100                 sv_setiv(sv, (IV)grent->gr_gid);
4101             else
4102                 sv_setpv(sv, grent->gr_name);
4103         }
4104         RETURN;
4105     }
4106
4107     if (grent) {
4108         PUSHs(sv = sv_mortalcopy(&sv_no));
4109         sv_setpv(sv, grent->gr_name);
4110         PUSHs(sv = sv_mortalcopy(&sv_no));
4111         sv_setpv(sv, grent->gr_passwd);
4112         PUSHs(sv = sv_mortalcopy(&sv_no));
4113         sv_setiv(sv, (IV)grent->gr_gid);
4114         PUSHs(sv = sv_mortalcopy(&sv_no));
4115         for (elem = grent->gr_mem; *elem; elem++) {
4116             sv_catpv(sv, *elem);
4117             if (elem[1])
4118                 sv_catpvn(sv, " ", 1);
4119         }
4120     }
4121
4122     RETURN;
4123 #else
4124     DIE(no_func, "getgrent");
4125 #endif
4126 }
4127
4128 PP(pp_sgrent)
4129 {
4130     dSP;
4131 #ifdef HAS_GROUP
4132     setgrent();
4133     RETPUSHYES;
4134 #else
4135     DIE(no_func, "setgrent");
4136 #endif
4137 }
4138
4139 PP(pp_egrent)
4140 {
4141     dSP;
4142 #ifdef HAS_GROUP
4143     endgrent();
4144     RETPUSHYES;
4145 #else
4146     DIE(no_func, "endgrent");
4147 #endif
4148 }
4149
4150 PP(pp_getlogin)
4151 {
4152     dSP; dTARGET;
4153 #ifdef HAS_GETLOGIN
4154     char *tmps;
4155     EXTEND(SP, 1);
4156     if (!(tmps = getlogin()))
4157         RETPUSHUNDEF;
4158     PUSHp(tmps, strlen(tmps));
4159     RETURN;
4160 #else
4161     DIE(no_func, "getlogin");
4162 #endif
4163 }
4164
4165 /* Miscellaneous. */
4166
4167 PP(pp_syscall)
4168 {
4169 #ifdef HAS_SYSCALL
4170     dSP; dMARK; dORIGMARK; dTARGET;
4171     register I32 items = SP - MARK;
4172     unsigned long a[20];
4173     register I32 i = 0;
4174     I32 retval = -1;
4175     MAGIC *mg;
4176
4177     if (tainting) {
4178         while (++MARK <= SP) {
4179             if (SvTAINTED(*MARK)) {
4180                 TAINT;
4181                 break;
4182             }
4183         }
4184         MARK = ORIGMARK;
4185         TAINT_PROPER("syscall");
4186     }
4187
4188     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4189      * or where sizeof(long) != sizeof(char*).  But such machines will
4190      * not likely have syscall implemented either, so who cares?
4191      */
4192     while (++MARK <= SP) {
4193         if (SvNIOK(*MARK) || !i)
4194             a[i++] = SvIV(*MARK);
4195         else if (*MARK == &sv_undef)
4196             a[i++] = 0;
4197         else
4198             a[i++] = (unsigned long)SvPV_force(*MARK, na);
4199         if (i > 15)
4200             break;
4201     }
4202     switch (items) {
4203     default:
4204         DIE("Too many args to syscall");
4205     case 0:
4206         DIE("Too few args to syscall");
4207     case 1:
4208         retval = syscall(a[0]);
4209         break;
4210     case 2:
4211         retval = syscall(a[0],a[1]);
4212         break;
4213     case 3:
4214         retval = syscall(a[0],a[1],a[2]);
4215         break;
4216     case 4:
4217         retval = syscall(a[0],a[1],a[2],a[3]);
4218         break;
4219     case 5:
4220         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4221         break;
4222     case 6:
4223         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4224         break;
4225     case 7:
4226         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4227         break;
4228     case 8:
4229         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4230         break;
4231 #ifdef atarist
4232     case 9:
4233         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4234         break;
4235     case 10:
4236         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4237         break;
4238     case 11:
4239         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4240           a[10]);
4241         break;
4242     case 12:
4243         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4244           a[10],a[11]);
4245         break;
4246     case 13:
4247         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4248           a[10],a[11],a[12]);
4249         break;
4250     case 14:
4251         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4252           a[10],a[11],a[12],a[13]);
4253         break;
4254 #endif /* atarist */
4255     }
4256     SP = ORIGMARK;
4257     PUSHi(retval);
4258     RETURN;
4259 #else
4260     DIE(no_func, "syscall");
4261 #endif
4262 }
4263
4264 #ifdef FCNTL_EMULATE_FLOCK
4265
4266 /*  XXX Emulate flock() with fcntl().
4267     What's really needed is a good file locking module.
4268 */
4269
4270 static int
4271 fcntl_emulate_flock(fd, operation)
4272 int fd;
4273 int operation;
4274 {
4275     struct flock flock;
4276
4277     switch (operation & ~LOCK_NB) {
4278     case LOCK_SH:
4279         flock.l_type = F_RDLCK;
4280         break;
4281     case LOCK_EX:
4282         flock.l_type = F_WRLCK;
4283         break;
4284     case LOCK_UN:
4285         flock.l_type = F_UNLCK;
4286         break;
4287     default:
4288         errno = EINVAL;
4289         return -1;
4290     }
4291     flock.l_whence = SEEK_SET;
4292     flock.l_start = flock.l_len = 0L;
4293
4294     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4295 }
4296
4297 #endif /* FCNTL_EMULATE_FLOCK */
4298
4299 #ifdef LOCKF_EMULATE_FLOCK
4300
4301 /*  XXX Emulate flock() with lockf().  This is just to increase
4302     portability of scripts.  The calls are not completely
4303     interchangeable.  What's really needed is a good file
4304     locking module.
4305 */
4306
4307 /*  The lockf() constants might have been defined in <unistd.h>.
4308     Unfortunately, <unistd.h> causes troubles on some mixed
4309     (BSD/POSIX) systems, such as SunOS 4.1.3.
4310
4311    Further, the lockf() constants aren't POSIX, so they might not be
4312    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
4313    just stick in the SVID values and be done with it.  Sigh.
4314 */
4315
4316 # ifndef F_ULOCK
4317 #  define F_ULOCK       0       /* Unlock a previously locked region */
4318 # endif
4319 # ifndef F_LOCK
4320 #  define F_LOCK        1       /* Lock a region for exclusive use */
4321 # endif
4322 # ifndef F_TLOCK
4323 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
4324 # endif
4325 # ifndef F_TEST
4326 #  define F_TEST        3       /* Test a region for other processes locks */
4327 # endif
4328
4329 static int
4330 lockf_emulate_flock (fd, operation)
4331 int fd;
4332 int operation;
4333 {
4334     int i;
4335     switch (operation) {
4336
4337         /* LOCK_SH - get a shared lock */
4338         case LOCK_SH:
4339         /* LOCK_EX - get an exclusive lock */
4340         case LOCK_EX:
4341             i = lockf (fd, F_LOCK, 0);
4342             break;
4343
4344         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4345         case LOCK_SH|LOCK_NB:
4346         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4347         case LOCK_EX|LOCK_NB:
4348             i = lockf (fd, F_TLOCK, 0);
4349             if (i == -1)
4350                 if ((errno == EAGAIN) || (errno == EACCES))
4351                     errno = EWOULDBLOCK;
4352             break;
4353
4354         /* LOCK_UN - unlock (non-blocking is a no-op) */
4355         case LOCK_UN:
4356         case LOCK_UN|LOCK_NB:
4357             i = lockf (fd, F_ULOCK, 0);
4358             break;
4359
4360         /* Default - can't decipher operation */
4361         default:
4362             i = -1;
4363             errno = EINVAL;
4364             break;
4365     }
4366     return (i);
4367 }
4368
4369 #endif /* LOCKF_EMULATE_FLOCK */