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