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