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