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