home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / doio.c < prev    next >
C/C++ Source or Header  |  2000-03-18  |  46KB  |  2,024 lines
  1. /*    doio.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.  * "Far below them they saw the white waters pour into a foaming bowl, and
  12.  * then swirl darkly about a deep oval basin in the rocks, until they found
  13.  * their way out again through a narrow gate, and flowed away, fuming and
  14.  * chattering, into calmer and more level reaches."
  15.  */
  16.  
  17. #include "EXTERN.h"
  18. #define PERL_IN_DOIO_C
  19. #include "perl.h"
  20.  
  21. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  22. #ifndef HAS_SEM
  23. #include <sys/ipc.h>
  24. #endif
  25. #ifdef HAS_MSG
  26. #include <sys/msg.h>
  27. #endif
  28. #ifdef HAS_SHM
  29. #include <sys/shm.h>
  30. # ifndef HAS_SHMAT_PROTOTYPE
  31.     extern Shmat_t shmat (int, char *, int);
  32. # endif
  33. #endif
  34. #endif
  35.  
  36. #ifdef I_UTIME
  37. #  if defined(_MSC_VER) || defined(__MINGW32__)
  38. #    include <sys/utime.h>
  39. #  else
  40. #    include <utime.h>
  41. #  endif
  42. #endif
  43.  
  44. #ifdef O_EXCL
  45. #  define OPEN_EXCL O_EXCL
  46. #else
  47. #  define OPEN_EXCL 0
  48. #endif
  49.  
  50. #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  51. #include <signal.h>
  52. #endif
  53.  
  54. /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  55. #ifdef I_UNISTD
  56. #  include <unistd.h>
  57. #endif
  58.  
  59. #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
  60. # include <sys/socket.h>
  61. # if defined(USE_SOCKS) && defined(I_SOCKS)
  62. #   include <socks.h>
  63. # endif 
  64. # ifdef I_NETBSD
  65. #  include <netdb.h>
  66. # endif
  67. # ifndef ENOTSOCK
  68. #  ifdef I_NET_ERRNO
  69. #   include <net/errno.h>
  70. #  endif
  71. # endif
  72. #endif
  73.  
  74. bool
  75. Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  76.          int rawmode, int rawperm, PerlIO *supplied_fp)
  77. {
  78.     return do_open9(gv, name, len, as_raw, rawmode, rawperm,
  79.             supplied_fp, Nullsv, 0);
  80. }
  81.  
  82. bool
  83. Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
  84.           int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
  85.           I32 num_svs)
  86. {
  87.     register IO *io = GvIOn(gv);
  88.     PerlIO *saveifp = Nullfp;
  89.     PerlIO *saveofp = Nullfp;
  90.     char savetype = ' ';
  91.     int writing = 0;
  92.     PerlIO *fp;
  93.     int fd;
  94.     int result;
  95.     bool was_fdopen = FALSE;
  96.     bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
  97.  
  98.     PL_forkprocess = 1;        /* assume true if no fork */
  99.  
  100.     if (PL_op && PL_op->op_type == OP_OPEN) {
  101.     /* set up disciplines */
  102.     U8 flags = PL_op->op_private;
  103.     in_raw = (flags & OPpOPEN_IN_RAW);
  104.     in_crlf = (flags & OPpOPEN_IN_CRLF);
  105.     out_raw = (flags & OPpOPEN_OUT_RAW);
  106.     out_crlf = (flags & OPpOPEN_OUT_CRLF);
  107.     }
  108.  
  109.     if (IoIFP(io)) {
  110.     fd = PerlIO_fileno(IoIFP(io));
  111.     if (IoTYPE(io) == '-')
  112.         result = 0;
  113.     else if (fd <= PL_maxsysfd) {
  114.         saveifp = IoIFP(io);
  115.         saveofp = IoOFP(io);
  116.         savetype = IoTYPE(io);
  117.         result = 0;
  118.     }
  119.     else if (IoTYPE(io) == '|')
  120.         result = PerlProc_pclose(IoIFP(io));
  121.     else if (IoIFP(io) != IoOFP(io)) {
  122.         if (IoOFP(io)) {
  123.         result = PerlIO_close(IoOFP(io));
  124.         PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
  125.         }
  126.         else
  127.         result = PerlIO_close(IoIFP(io));
  128.     }
  129.     else
  130.         result = PerlIO_close(IoIFP(io));
  131.     if (result == EOF && fd > PL_maxsysfd)
  132.         PerlIO_printf(Perl_error_log,
  133.               "Warning: unable to close filehandle %s properly.\n",
  134.               GvENAME(gv));
  135.     IoOFP(io) = IoIFP(io) = Nullfp;
  136.     }
  137.  
  138.     if (as_raw) {
  139. #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
  140.     rawmode |= O_LARGEFILE;
  141. #endif
  142.  
  143. #ifndef O_ACCMODE
  144. #define O_ACCMODE 3        /* Assume traditional implementation */
  145. #endif
  146.  
  147.     switch (result = rawmode & O_ACCMODE) {
  148.     case O_RDONLY:
  149.          IoTYPE(io) = '<';
  150.          break;
  151.     case O_WRONLY:
  152.          IoTYPE(io) = '>';
  153.          break;
  154.     case O_RDWR:
  155.     default:
  156.          IoTYPE(io) = '+';
  157.          break;
  158.     }
  159.  
  160.     writing = (result > 0);
  161.     fd = PerlLIO_open3(name, rawmode, rawperm);
  162.  
  163.     if (fd == -1)
  164.         fp = NULL;
  165.     else {
  166.         char fpmode[4];
  167.         STRLEN ix = 0;
  168.         if (result == O_RDONLY)
  169.         fpmode[ix++] = 'r';
  170. #ifdef O_APPEND
  171.         else if (rawmode & O_APPEND) {
  172.         fpmode[ix++] = 'a';
  173.         if (result != O_WRONLY)
  174.             fpmode[ix++] = '+';
  175.         }
  176. #endif
  177.         else {
  178.         if (result == O_WRONLY)
  179.             fpmode[ix++] = 'w';
  180.         else {
  181.             fpmode[ix++] = 'r';
  182.             fpmode[ix++] = '+';
  183.         }
  184.         }
  185.         if (rawmode & O_BINARY)
  186.         fpmode[ix++] = 'b';
  187.         fpmode[ix] = '\0';
  188.         fp = PerlIO_fdopen(fd, fpmode);
  189.         if (!fp)
  190.         PerlLIO_close(fd);
  191.     }
  192.     }
  193.     else {
  194.     char *type;
  195.     char *oname = name;
  196.     STRLEN tlen;
  197.     STRLEN olen = len;
  198.     char mode[4];        /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
  199.     int dodup;
  200.  
  201.     type = savepvn(name, len);
  202.     tlen = len;
  203.     SAVEFREEPV(type);
  204.     if (num_svs) {
  205.         STRLEN l;
  206.         name = SvPV(svs, l) ;
  207.         len = (I32)l;
  208.         name = savepvn(name, len);
  209.         SAVEFREEPV(name);
  210.     }
  211.     else {
  212.         while (tlen && isSPACE(type[tlen-1]))
  213.         type[--tlen] = '\0';
  214.         name = type;
  215.         len = tlen;
  216.     }
  217.     mode[0] = mode[1] = mode[2] = mode[3] = '\0';
  218.     IoTYPE(io) = *type;
  219.     if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */
  220.         mode[1] = *type++;
  221.         --tlen;
  222.         writing = 1;
  223.     }
  224.  
  225.     if (*type == '|') {
  226.         if (num_svs && (tlen != 2 || type[1] != '-')) {
  227.           unknown_desr:
  228.         Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
  229.         }
  230.         /*SUPPRESS 530*/
  231.         for (type++, tlen--; isSPACE(*type); type++, tlen--) ;
  232.         if (!num_svs) {
  233.         name = type;
  234.         len = tlen;
  235.         }
  236.         if (*name == '\0') { /* command is missing 19990114 */
  237.         dTHR;
  238.         if (ckWARN(WARN_PIPE))
  239.             Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
  240.         errno = EPIPE;
  241.         goto say_false;
  242.         }
  243.         if (strNE(name,"-") || num_svs)
  244.         TAINT_ENV();
  245.         TAINT_PROPER("piped open");
  246.         if (name[len-1] == '|') {
  247.         dTHR;
  248.         name[--len] = '\0' ;
  249.         if (ckWARN(WARN_PIPE))
  250.             Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
  251.         }
  252.         {
  253.         char *mode;
  254.         if (out_raw)
  255.             mode = "wb";
  256.         else if (out_crlf)
  257.             mode = "wt";
  258.         else
  259.             mode = "w";
  260.         fp = PerlProc_popen(name,mode);
  261.         }
  262.         writing = 1;
  263.     }
  264.     else if (*type == '>') {
  265.         TAINT_PROPER("open");
  266.         type++;
  267.         if (*type == '>') {
  268.         mode[0] = IoTYPE(io) = 'a';
  269.         type++;
  270.         tlen--;
  271.         }
  272.         else
  273.         mode[0] = 'w';
  274.         writing = 1;
  275.  
  276.         if (out_raw)
  277.         strcat(mode, "b");
  278.         else if (out_crlf)
  279.         strcat(mode, "t");
  280.  
  281.         if (num_svs && tlen != 1)
  282.             goto unknown_desr;
  283.         if (*type == '&') {
  284.         name = type;
  285.           duplicity:
  286.         dodup = 1;
  287.         name++;
  288.         if (*name == '=') {
  289.             dodup = 0;
  290.             name++;
  291.         }
  292.         if (!*name && supplied_fp)
  293.             fp = supplied_fp;
  294.         else {
  295.             /*SUPPRESS 530*/
  296.             for (; isSPACE(*name); name++) ;
  297.             if (isDIGIT(*name))
  298.             fd = atoi(name);
  299.             else {
  300.             IO* thatio;
  301.             gv = gv_fetchpv(name,FALSE,SVt_PVIO);
  302.             thatio = GvIO(gv);
  303.             if (!thatio) {
  304. #ifdef EINVAL
  305.                 SETERRNO(EINVAL,SS$_IVCHAN);
  306. #endif
  307.                 goto say_false;
  308.             }
  309.             if (IoIFP(thatio)) {
  310.                 PerlIO *fp = IoIFP(thatio);
  311.                 /* Flush stdio buffer before dup. --mjd
  312.                  * Unfortunately SEEK_CURing 0 seems to
  313.                  * be optimized away on most platforms;
  314.                  * only Solaris and Linux seem to flush
  315.                  * on that. --jhi */
  316.                 PerlIO_seek(fp, 0, SEEK_CUR);
  317.                 /* On the other hand, do all platforms
  318.                  * take gracefully to flushing a read-only
  319.                  * filehandle?  Perhaps we should do
  320.                  * fsetpos(src)+fgetpos(dst)?  --nik */
  321.                 PerlIO_flush(fp);
  322.                 fd = PerlIO_fileno(fp);
  323.                 if (IoTYPE(thatio) == 's')
  324.                 IoTYPE(io) = 's';
  325.             }
  326.             else
  327.                 fd = -1;
  328.             }
  329.             if (dodup)
  330.             fd = PerlLIO_dup(fd);
  331.             else
  332.             was_fdopen = TRUE;
  333.             if (!(fp = PerlIO_fdopen(fd,mode))) {
  334.             if (dodup)
  335.                 PerlLIO_close(fd);
  336.             }
  337.         }
  338.         }
  339.         else {
  340.         /*SUPPRESS 530*/
  341.         for (; isSPACE(*type); type++) ;
  342.         if (strEQ(type,"-")) {
  343.             fp = PerlIO_stdout();
  344.             IoTYPE(io) = '-';
  345.         }
  346.         else  {
  347.             fp = PerlIO_open((num_svs ? name : type), mode);
  348.         }
  349.         }
  350.     }
  351.     else if (*type == '<') {
  352.         if (num_svs && tlen != 1)
  353.             goto unknown_desr;
  354.         /*SUPPRESS 530*/
  355.         for (type++; isSPACE(*type); type++) ;
  356.         mode[0] = 'r';
  357.         if (in_raw)
  358.         strcat(mode, "b");
  359.         else if (in_crlf)
  360.         strcat(mode, "t");
  361.  
  362.         if (*type == '&') {
  363.         name = type;
  364.         goto duplicity;
  365.         }
  366.         if (strEQ(type,"-")) {
  367.         fp = PerlIO_stdin();
  368.         IoTYPE(io) = '-';
  369.         }
  370.         else
  371.         fp = PerlIO_open((num_svs ? name : type), mode);
  372.     }
  373.     else if (tlen > 1 && type[tlen-1] == '|') {
  374.         if (num_svs) {
  375.         if (tlen != 2 || type[0] != '-')
  376.             goto unknown_desr;
  377.         }
  378.         else {
  379.         type[--tlen] = '\0';
  380.         while (tlen && isSPACE(type[tlen-1]))
  381.             type[--tlen] = '\0';
  382.         /*SUPPRESS 530*/
  383.         for (; isSPACE(*type); type++) ;
  384.         name = type;
  385.         }
  386.         if (*name == '\0') { /* command is missing 19990114 */
  387.         dTHR;
  388.         if (ckWARN(WARN_PIPE))
  389.             Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
  390.         errno = EPIPE;
  391.         goto say_false;
  392.         }
  393.         if (strNE(name,"-") || num_svs)
  394.         TAINT_ENV();
  395.         TAINT_PROPER("piped open");
  396.         {
  397.         char *mode;
  398.         if (in_raw)
  399.             mode = "rb";
  400.         else if (in_crlf)
  401.             mode = "rt";
  402.         else
  403.             mode = "r";
  404.         fp = PerlProc_popen(name,mode);
  405.         }
  406.         IoTYPE(io) = '|';
  407.     }
  408.     else {
  409.         if (num_svs)
  410.         goto unknown_desr;
  411.         name = type;
  412.         IoTYPE(io) = '<';
  413.         /*SUPPRESS 530*/
  414.         for (; isSPACE(*name); name++) ;
  415.         if (strEQ(name,"-")) {
  416.         fp = PerlIO_stdin();
  417.         IoTYPE(io) = '-';
  418.         }
  419.         else {
  420.         char *mode;
  421.         if (in_raw)
  422.             mode = "rb";
  423.         else if (in_crlf)
  424.             mode = "rt";
  425.         else
  426.             mode = "r";
  427.         fp = PerlIO_open(name,mode);
  428.         }
  429.     }
  430.     }
  431.     if (!fp) {
  432.     dTHR;
  433.     if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
  434.         Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
  435.     goto say_false;
  436.     }
  437.     if (IoTYPE(io) &&
  438.       IoTYPE(io) != '|' && IoTYPE(io) != '-') {
  439.     dTHR;
  440.     if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
  441.         (void)PerlIO_close(fp);
  442.         goto say_false;
  443.     }
  444.     if (S_ISSOCK(PL_statbuf.st_mode))
  445.         IoTYPE(io) = 's';    /* in case a socket was passed in to us */
  446. #ifdef HAS_SOCKET
  447.     else if (
  448. #ifdef S_IFMT
  449.         !(PL_statbuf.st_mode & S_IFMT)
  450. #else
  451.         !PL_statbuf.st_mode
  452. #endif
  453.     ) {
  454.         char tmpbuf[256];
  455.         Sock_size_t buflen = sizeof tmpbuf;
  456.         if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
  457.                 &buflen) >= 0
  458.           || errno != ENOTSOCK)
  459.         IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
  460.                 /* but some return 0 for streams too, sigh */
  461.     }
  462. #endif
  463.     }
  464.     if (saveifp) {        /* must use old fp? */
  465.     fd = PerlIO_fileno(saveifp);
  466.     if (saveofp) {
  467.         PerlIO_flush(saveofp);        /* emulate PerlIO_close() */
  468.         if (saveofp != saveifp) {    /* was a socket? */
  469.         PerlIO_close(saveofp);
  470.         if (fd > 2)
  471.             Safefree(saveofp);
  472.         }
  473.     }
  474.     if (fd != PerlIO_fileno(fp)) {
  475.         Pid_t pid;
  476.         SV *sv;
  477.  
  478.         PerlLIO_dup2(PerlIO_fileno(fp), fd);
  479.         sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
  480.         (void)SvUPGRADE(sv, SVt_IV);
  481.         pid = SvIVX(sv);
  482.         SvIVX(sv) = 0;
  483.         sv = *av_fetch(PL_fdpid,fd,TRUE);
  484.         (void)SvUPGRADE(sv, SVt_IV);
  485.         SvIVX(sv) = pid;
  486.         if (!was_fdopen)
  487.         PerlIO_close(fp);
  488.  
  489.     }
  490.     fp = saveifp;
  491.     PerlIO_clearerr(fp);
  492.     }
  493. #if defined(HAS_FCNTL) && defined(F_SETFD)
  494.     {
  495.     int save_errno = errno;
  496.     fd = PerlIO_fileno(fp);
  497.     fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
  498.     errno = save_errno;
  499.     }
  500. #endif
  501.     IoIFP(io) = fp;
  502.     IoFLAGS(io) &= ~IOf_NOLINE;
  503.     if (writing) {
  504.     dTHR;
  505.     if (IoTYPE(io) == 's'
  506.         || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) )
  507.     {
  508.         char *mode;
  509.         if (out_raw)
  510.         mode = "wb";
  511.         else if (out_crlf)
  512.         mode = "wt";
  513.         else
  514.         mode = "w";
  515.  
  516.         if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) {
  517.         PerlIO_close(fp);
  518.         IoIFP(io) = Nullfp;
  519.         goto say_false;
  520.         }
  521.     }
  522.     else
  523.         IoOFP(io) = fp;
  524.     }
  525.     return TRUE;
  526.  
  527. say_false:
  528.     IoIFP(io) = saveifp;
  529.     IoOFP(io) = saveofp;
  530.     IoTYPE(io) = savetype;
  531.     return FALSE;
  532. }
  533.  
  534. PerlIO *
  535. Perl_nextargv(pTHX_ register GV *gv)
  536. {
  537.     register SV *sv;
  538. #ifndef FLEXFILENAMES
  539.     int filedev;
  540.     int fileino;
  541. #endif
  542.     Uid_t fileuid;
  543.     Gid_t filegid;
  544.     IO *io = GvIOp(gv);
  545.  
  546.     if (!PL_argvoutgv)
  547.     PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
  548.     if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
  549.     IoFLAGS(io) &= ~IOf_START;
  550.     if (PL_inplace) {
  551.         if (!PL_argvout_stack)
  552.         PL_argvout_stack = newAV();
  553.         av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
  554.     }
  555.     }
  556.     if (PL_filemode & (S_ISUID|S_ISGID)) {
  557.     PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
  558. #ifdef HAS_FCHMOD
  559.     (void)fchmod(PL_lastfd,PL_filemode);
  560. #else
  561.     (void)PerlLIO_chmod(PL_oldname,PL_filemode);
  562. #endif
  563.     }
  564.     PL_filemode = 0;
  565.     while (av_len(GvAV(gv)) >= 0) {
  566.     dTHR;
  567.     STRLEN oldlen;
  568.     sv = av_shift(GvAV(gv));
  569.     SAVEFREESV(sv);
  570.     sv_setsv(GvSV(gv),sv);
  571.     SvSETMAGIC(GvSV(gv));
  572.     PL_oldname = SvPVx(GvSV(gv), oldlen);
  573.     if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
  574.         if (PL_inplace) {
  575.         TAINT_PROPER("inplace open");
  576.         if (oldlen == 1 && *PL_oldname == '-') {
  577.             setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
  578.             return IoIFP(GvIOp(gv));
  579.         }
  580. #ifndef FLEXFILENAMES
  581.         filedev = PL_statbuf.st_dev;
  582.         fileino = PL_statbuf.st_ino;
  583. #endif
  584.         PL_filemode = PL_statbuf.st_mode;
  585.         fileuid = PL_statbuf.st_uid;
  586.         filegid = PL_statbuf.st_gid;
  587.         if (!S_ISREG(PL_filemode)) {
  588.             if (ckWARN_d(WARN_INPLACE))    
  589.                 Perl_warner(aTHX_ WARN_INPLACE,
  590.                 "Can't do inplace edit: %s is not a regular file",
  591.                     PL_oldname );
  592.             do_close(gv,FALSE);
  593.             continue;
  594.         }
  595.         if (*PL_inplace) {
  596.             char *star = strchr(PL_inplace, '*');
  597.             if (star) {
  598.             char *begin = PL_inplace;
  599.             sv_setpvn(sv, "", 0);
  600.             do {
  601.                 sv_catpvn(sv, begin, star - begin);
  602.                 sv_catpvn(sv, PL_oldname, oldlen);
  603.                 begin = ++star;
  604.             } while ((star = strchr(begin, '*')));
  605.             if (*begin)
  606.                 sv_catpv(sv,begin);
  607.             }
  608.             else {
  609.             sv_catpv(sv,PL_inplace);
  610.             }
  611. #ifndef FLEXFILENAMES
  612.             if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
  613.               && PL_statbuf.st_dev == filedev
  614.               && PL_statbuf.st_ino == fileino
  615. #ifdef DJGPP
  616.                       || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
  617. #endif
  618.                       )
  619.             {
  620.             if (ckWARN_d(WARN_INPLACE))    
  621.                 Perl_warner(aTHX_ WARN_INPLACE,
  622.                   "Can't do inplace edit: %s would not be unique",
  623.                   SvPVX(sv));
  624.             do_close(gv,FALSE);
  625.             continue;
  626.             }
  627. #endif
  628. #ifdef HAS_RENAME
  629. #if !defined(DOSISH) && !defined(__CYGWIN__)
  630.             if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
  631.                 if (ckWARN_d(WARN_INPLACE))    
  632.                 Perl_warner(aTHX_ WARN_INPLACE, 
  633.                   "Can't rename %s to %s: %s, skipping file",
  634.                   PL_oldname, SvPVX(sv), Strerror(errno) );
  635.             do_close(gv,FALSE);
  636.             continue;
  637.             }
  638. #else
  639.             do_close(gv,FALSE);
  640.             (void)PerlLIO_unlink(SvPVX(sv));
  641.             (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
  642.             do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
  643. #endif /* DOSISH */
  644. #else
  645.             (void)UNLINK(SvPVX(sv));
  646.             if (link(PL_oldname,SvPVX(sv)) < 0) {
  647.                 if (ckWARN_d(WARN_INPLACE))    
  648.                 Perl_warner(aTHX_ WARN_INPLACE,
  649.                   "Can't rename %s to %s: %s, skipping file",
  650.                   PL_oldname, SvPVX(sv), Strerror(errno) );
  651.             do_close(gv,FALSE);
  652.             continue;
  653.             }
  654.             (void)UNLINK(PL_oldname);
  655. #endif
  656.         }
  657.         else {
  658. #if !defined(DOSISH) && !defined(AMIGAOS)
  659. #  ifndef VMS  /* Don't delete; use automatic file versioning */
  660.             if (UNLINK(PL_oldname) < 0) {
  661.                 if (ckWARN_d(WARN_INPLACE))    
  662.                 Perl_warner(aTHX_ WARN_INPLACE,
  663.                   "Can't remove %s: %s, skipping file",
  664.                   PL_oldname, Strerror(errno) );
  665.             do_close(gv,FALSE);
  666.             continue;
  667.             }
  668. #  endif
  669. #else
  670.             Perl_croak(aTHX_ "Can't do inplace edit without backup");
  671. #endif
  672.         }
  673.  
  674.         sv_setpvn(sv,">",!PL_inplace);
  675.         sv_catpvn(sv,PL_oldname,oldlen);
  676.         SETERRNO(0,0);        /* in case sprintf set errno */
  677. #ifdef VMS
  678.         if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
  679.                  O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
  680. #else
  681.         if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
  682.                  O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
  683. #endif
  684.         {
  685.             if (ckWARN_d(WARN_INPLACE))    
  686.                 Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
  687.                   PL_oldname, Strerror(errno) );
  688.             do_close(gv,FALSE);
  689.             continue;
  690.         }
  691.         setdefout(PL_argvoutgv);
  692.         PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
  693.         (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
  694. #ifdef HAS_FCHMOD
  695.         (void)fchmod(PL_lastfd,PL_filemode);
  696. #else
  697. #  if !(defined(WIN32) && defined(__BORLANDC__))
  698.         /* Borland runtime creates a readonly file! */
  699.         (void)PerlLIO_chmod(PL_oldname,PL_filemode);
  700. #  endif
  701. #endif
  702.         if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
  703. #ifdef HAS_FCHOWN
  704.             (void)fchown(PL_lastfd,fileuid,filegid);
  705. #else
  706. #ifdef HAS_CHOWN
  707.             (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
  708. #endif
  709. #endif
  710.         }
  711.         }
  712.         return IoIFP(GvIOp(gv));
  713.     }
  714.     else {
  715.         dTHR;
  716.         if (ckWARN_d(WARN_INPLACE)) {
  717.         int eno = errno;
  718.         if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
  719.             && !S_ISREG(PL_statbuf.st_mode))    
  720.         {
  721.             Perl_warner(aTHX_ WARN_INPLACE,
  722.                 "Can't do inplace edit: %s is not a regular file",
  723.                 PL_oldname);
  724.         }
  725.         else
  726.             Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s",
  727.                 PL_oldname, Strerror(eno));
  728.         }
  729.     }
  730.     }
  731.     if (io && (IoFLAGS(io) & IOf_ARGV))
  732.     IoFLAGS(io) |= IOf_START;
  733.     if (PL_inplace) {
  734.     (void)do_close(PL_argvoutgv,FALSE);
  735.     if (io && (IoFLAGS(io) & IOf_ARGV)
  736.         && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
  737.     {
  738.         GV *oldout = (GV*)av_pop(PL_argvout_stack);
  739.         setdefout(oldout);
  740.         SvREFCNT_dec(oldout);
  741.         return Nullfp;
  742.     }
  743.     setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
  744.     }
  745.     return Nullfp;
  746. }
  747.  
  748. #ifdef HAS_PIPE
  749. void
  750. Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
  751. {
  752.     register IO *rstio;
  753.     register IO *wstio;
  754.     int fd[2];
  755.  
  756.     if (!rgv)
  757.     goto badexit;
  758.     if (!wgv)
  759.     goto badexit;
  760.  
  761.     rstio = GvIOn(rgv);
  762.     wstio = GvIOn(wgv);
  763.  
  764.     if (IoIFP(rstio))
  765.     do_close(rgv,FALSE);
  766.     if (IoIFP(wstio))
  767.     do_close(wgv,FALSE);
  768.  
  769.     if (PerlProc_pipe(fd) < 0)
  770.     goto badexit;
  771.     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
  772.     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
  773.     IoIFP(wstio) = IoOFP(wstio);
  774.     IoTYPE(rstio) = '<';
  775.     IoTYPE(wstio) = '>';
  776.     if (!IoIFP(rstio) || !IoOFP(wstio)) {
  777.     if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
  778.     else PerlLIO_close(fd[0]);
  779.     if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
  780.     else PerlLIO_close(fd[1]);
  781.     goto badexit;
  782.     }
  783.  
  784.     sv_setsv(sv,&PL_sv_yes);
  785.     return;
  786.  
  787. badexit:
  788.     sv_setsv(sv,&PL_sv_undef);
  789.     return;
  790. }
  791. #endif
  792.  
  793. /* explicit renamed to avoid C++ conflict    -- kja */
  794. bool
  795. Perl_do_close(pTHX_ GV *gv, bool not_implicit)
  796. {
  797.     bool retval;
  798.     IO *io;
  799.  
  800.     if (!gv)
  801.     gv = PL_argvgv;
  802.     if (!gv || SvTYPE(gv) != SVt_PVGV) {
  803.     if (not_implicit)
  804.         SETERRNO(EBADF,SS$_IVCHAN);
  805.     return FALSE;
  806.     }
  807.     io = GvIO(gv);
  808.     if (!io) {        /* never opened */
  809.     if (not_implicit) {
  810.         dTHR;
  811.         if (ckWARN(WARN_UNOPENED))
  812.         Perl_warner(aTHX_ WARN_UNOPENED, 
  813.                "Close on unopened file <%s>",GvENAME(gv));
  814.         SETERRNO(EBADF,SS$_IVCHAN);
  815.     }
  816.     return FALSE;
  817.     }
  818.     retval = io_close(io, not_implicit);
  819.     if (not_implicit) {
  820.     IoLINES(io) = 0;
  821.     IoPAGE(io) = 0;
  822.     IoLINES_LEFT(io) = IoPAGE_LEN(io);
  823.     }
  824.     IoTYPE(io) = ' ';
  825.     return retval;
  826. }
  827.  
  828. bool
  829. Perl_io_close(pTHX_ IO *io, bool not_implicit)
  830. {
  831.     bool retval = FALSE;
  832.     int status;
  833.  
  834.     if (IoIFP(io)) {
  835.     if (IoTYPE(io) == '|') {
  836.         status = PerlProc_pclose(IoIFP(io));
  837.         if (not_implicit) {
  838.         STATUS_NATIVE_SET(status);
  839.         retval = (STATUS_POSIX == 0);
  840.         }
  841.         else {
  842.         retval = (status != -1);
  843.         }
  844.     }
  845.     else if (IoTYPE(io) == '-')
  846.         retval = TRUE;
  847.     else {
  848.         if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {        /* a socket */
  849.         retval = (PerlIO_close(IoOFP(io)) != EOF);
  850.         PerlIO_close(IoIFP(io));    /* clear stdio, fd already closed */
  851.         }
  852.         else
  853.         retval = (PerlIO_close(IoIFP(io)) != EOF);
  854.     }
  855.     IoOFP(io) = IoIFP(io) = Nullfp;
  856.     }
  857.     else if (not_implicit) {
  858.     SETERRNO(EBADF,SS$_IVCHAN);
  859.     }
  860.  
  861.     return retval;
  862. }
  863.  
  864. bool
  865. Perl_do_eof(pTHX_ GV *gv)
  866. {
  867.     dTHR;
  868.     register IO *io;
  869.     int ch;
  870.  
  871.     io = GvIO(gv);
  872.  
  873.     if (!io)
  874.     return TRUE;
  875.     else if (ckWARN(WARN_IO)
  876.          && (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
  877.          || IoIFP(io) == PerlIO_stderr()))
  878.     {
  879.     SV* sv = sv_newmortal();
  880.     gv_efullname3(sv, gv, Nullch);
  881.     Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
  882.             SvPV_nolen(sv));
  883.     }
  884.  
  885.     while (IoIFP(io)) {
  886.  
  887.         if (PerlIO_has_cntptr(IoIFP(io))) {    /* (the code works without this) */
  888.         if (PerlIO_get_cnt(IoIFP(io)) > 0)    /* cheat a little, since */
  889.         return FALSE;            /* this is the most usual case */
  890.         }
  891.  
  892.     ch = PerlIO_getc(IoIFP(io));
  893.     if (ch != EOF) {
  894.         (void)PerlIO_ungetc(IoIFP(io),ch);
  895.         return FALSE;
  896.     }
  897.         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
  898.         if (PerlIO_get_cnt(IoIFP(io)) < -1)
  899.         PerlIO_set_cnt(IoIFP(io),-1);
  900.     }
  901.     if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
  902.         if (!nextargv(PL_argvgv))    /* get another fp handy */
  903.         return TRUE;
  904.     }
  905.     else
  906.         return TRUE;        /* normal fp, definitely end of file */
  907.     }
  908.     return TRUE;
  909. }
  910.  
  911. Off_t
  912. Perl_do_tell(pTHX_ GV *gv)
  913. {
  914.     register IO *io;
  915.     register PerlIO *fp;
  916.  
  917.     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
  918. #ifdef ULTRIX_STDIO_BOTCH
  919.     if (PerlIO_eof(fp))
  920.         (void)PerlIO_seek(fp, 0L, 2);    /* ultrix 1.2 workaround */
  921. #endif
  922.     return PerlIO_tell(fp);
  923.     }
  924.     {
  925.     dTHR;
  926.     if (ckWARN(WARN_UNOPENED))
  927.         Perl_warner(aTHX_ WARN_UNOPENED, "tell() on unopened file");
  928.     }
  929.     SETERRNO(EBADF,RMS$_IFI);
  930.     return (Off_t)-1;
  931. }
  932.  
  933. bool
  934. Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
  935. {
  936.     register IO *io;
  937.     register PerlIO *fp;
  938.  
  939.     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
  940. #ifdef ULTRIX_STDIO_BOTCH
  941.     if (PerlIO_eof(fp))
  942.         (void)PerlIO_seek(fp, 0L, 2);    /* ultrix 1.2 workaround */
  943. #endif
  944.     return PerlIO_seek(fp, pos, whence) >= 0;
  945.     }
  946.     {
  947.     dTHR;
  948.     if (ckWARN(WARN_UNOPENED))
  949.         Perl_warner(aTHX_ WARN_UNOPENED, "seek() on unopened file");
  950.     }
  951.     SETERRNO(EBADF,RMS$_IFI);
  952.     return FALSE;
  953. }
  954.  
  955. Off_t
  956. Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
  957. {
  958.     register IO *io;
  959.     register PerlIO *fp;
  960.  
  961.     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
  962.     return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
  963.     {
  964.     dTHR;
  965.     if (ckWARN(WARN_UNOPENED))
  966.         Perl_warner(aTHX_ WARN_UNOPENED, "sysseek() on unopened file");
  967.     }
  968.     SETERRNO(EBADF,RMS$_IFI);
  969.     return (Off_t)-1;
  970. }
  971.  
  972. int
  973. Perl_mode_from_discipline(pTHX_ SV *discp)
  974. {
  975.     int mode = O_BINARY;
  976.     if (discp) {
  977.     STRLEN len;
  978.     char *s = SvPV(discp,len);
  979.     while (*s) {
  980.         if (*s == ':') {
  981.         switch (s[1]) {
  982.         case 'r':
  983.             if (len > 3 && strnEQ(s+1, "raw", 3)
  984.             && (!s[4] || s[4] == ':' || isSPACE(s[4])))
  985.             {
  986.             mode = O_BINARY;
  987.             s += 4;
  988.             len -= 4;
  989.             break;
  990.             }
  991.             /* FALL THROUGH */
  992.         case 'c':
  993.             if (len > 4 && strnEQ(s+1, "crlf", 4)
  994.             && (!s[5] || s[5] == ':' || isSPACE(s[5])))
  995.             {
  996.             mode = O_TEXT;
  997.             s += 5;
  998.             len -= 5;
  999.             break;
  1000.             }
  1001.             /* FALL THROUGH */
  1002.         default:
  1003.             goto fail_discipline;
  1004.         }
  1005.         }
  1006.         else if (isSPACE(*s)) {
  1007.         ++s;
  1008.         --len;
  1009.         }
  1010.         else {
  1011.         char *end;
  1012. fail_discipline:
  1013.         end = strchr(s+1, ':');
  1014.         if (!end)
  1015.             end = s+len;
  1016.         Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s);
  1017.         }
  1018.     }
  1019.     }
  1020.     return mode;
  1021. }
  1022.  
  1023. int
  1024. Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
  1025. {
  1026. #ifdef DOSISH
  1027. #  if defined(atarist) || defined(__MINT__)
  1028.     if (!PerlIO_flush(fp)) {
  1029.     if (mode & O_BINARY)
  1030.         ((FILE*)fp)->_flag |= _IOBIN;
  1031.     else
  1032.         ((FILE*)fp)->_flag &= ~ _IOBIN;
  1033.     return 1;
  1034.     }
  1035.     return 0;
  1036. #  else
  1037.     if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
  1038. #    if defined(WIN32) && defined(__BORLANDC__)
  1039.     /* The translation mode of the stream is maintained independent
  1040.      * of the translation mode of the fd in the Borland RTL (heavy
  1041.      * digging through their runtime sources reveal).  User has to
  1042.      * set the mode explicitly for the stream (though they don't
  1043.      * document this anywhere). GSAR 97-5-24
  1044.      */
  1045.     PerlIO_seek(fp,0L,0);
  1046.     if (mode & O_BINARY)
  1047.         ((FILE*)fp)->flags |= _F_BIN;
  1048.     else
  1049.         ((FILE*)fp)->flags &= ~ _F_BIN;
  1050. #    endif
  1051.     return 1;
  1052.     }
  1053.     else
  1054.     return 0;
  1055. #  endif
  1056. #else
  1057. #  if defined(USEMYBINMODE)
  1058.     if (my_binmode(fp, iotype, mode) != FALSE)
  1059.     return 1;
  1060.     else
  1061.     return 0;
  1062. #  else
  1063.     return 1;
  1064. #  endif
  1065. #endif
  1066. }
  1067.  
  1068. #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
  1069.     /* code courtesy of William Kucharski */
  1070. #define HAS_CHSIZE
  1071.  
  1072. I32 my_chsize(fd, length)
  1073. I32 fd;            /* file descriptor */
  1074. Off_t length;        /* length to set file to */
  1075. {
  1076.     struct flock fl;
  1077.     struct stat filebuf;
  1078.  
  1079.     if (PerlLIO_fstat(fd, &filebuf) < 0)
  1080.     return -1;
  1081.  
  1082.     if (filebuf.st_size < length) {
  1083.  
  1084.     /* extend file length */
  1085.  
  1086.     if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
  1087.         return -1;
  1088.  
  1089.     /* write a "0" byte */
  1090.  
  1091.     if ((PerlLIO_write(fd, "", 1)) != 1)
  1092.         return -1;
  1093.     }
  1094.     else {
  1095.     /* truncate length */
  1096.  
  1097.     fl.l_whence = 0;
  1098.     fl.l_len = 0;
  1099.     fl.l_start = length;
  1100.     fl.l_type = F_WRLCK;    /* write lock on file space */
  1101.  
  1102.     /*
  1103.     * This relies on the UNDOCUMENTED F_FREESP argument to
  1104.     * fcntl(2), which truncates the file so that it ends at the
  1105.     * position indicated by fl.l_start.
  1106.     *
  1107.     * Will minor miracles never cease?
  1108.     */
  1109.  
  1110.     if (fcntl(fd, F_FREESP, &fl) < 0)
  1111.         return -1;
  1112.  
  1113.     }
  1114.  
  1115.     return 0;
  1116. }
  1117. #endif /* F_FREESP */
  1118.  
  1119. bool
  1120. Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
  1121. {
  1122.     register char *tmps;
  1123.     STRLEN len;
  1124.  
  1125.     /* assuming fp is checked earlier */
  1126.     if (!sv)
  1127.     return TRUE;
  1128.     if (PL_ofmt) {
  1129.     if (SvGMAGICAL(sv))
  1130.         mg_get(sv);
  1131.         if (SvIOK(sv) && SvIVX(sv) != 0) {
  1132.         PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
  1133.         return !PerlIO_error(fp);
  1134.     }
  1135.     if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
  1136.        || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
  1137.         PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
  1138.         return !PerlIO_error(fp);
  1139.     }
  1140.     }
  1141.     switch (SvTYPE(sv)) {
  1142.     case SVt_NULL:
  1143.     {
  1144.         dTHR;
  1145.         if (ckWARN(WARN_UNINITIALIZED))
  1146.         report_uninit();
  1147.     }
  1148.     return TRUE;
  1149.     case SVt_IV:
  1150.     if (SvIOK(sv)) {
  1151.         if (SvGMAGICAL(sv))
  1152.         mg_get(sv);
  1153.         if (SvIsUV(sv))
  1154.         PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
  1155.         else
  1156.         PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
  1157.         return !PerlIO_error(fp);
  1158.     }
  1159.     /* FALL THROUGH */
  1160.     default:
  1161.     tmps = SvPV(sv, len);
  1162.     break;
  1163.     }
  1164.     /* To detect whether the process is about to overstep its
  1165.      * filesize limit we would need getrlimit().  We could then
  1166.      * also transparently raise the limit with setrlimit() --
  1167.      * but only until the system hard limit/the filesystem limit,
  1168.      * at which we would get EPERM.  Note that when using buffered
  1169.      * io the write failure can be delayed until the flush/close. --jhi */
  1170.     if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
  1171.     return FALSE;
  1172.     return !PerlIO_error(fp);
  1173. }
  1174.  
  1175. I32
  1176. Perl_my_stat(pTHX)
  1177. {
  1178.     djSP;
  1179.     IO *io;
  1180.     GV* tmpgv;
  1181.  
  1182.     if (PL_op->op_flags & OPf_REF) {
  1183.     EXTEND(SP,1);
  1184.     tmpgv = cGVOP_gv;
  1185.       do_fstat:
  1186.     io = GvIO(tmpgv);
  1187.     if (io && IoIFP(io)) {
  1188.         PL_statgv = tmpgv;
  1189.         sv_setpv(PL_statname,"");
  1190.         PL_laststype = OP_STAT;
  1191.         return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
  1192.     }
  1193.     else {
  1194.         if (tmpgv == PL_defgv)
  1195.         return PL_laststatval;
  1196.         if (ckWARN(WARN_UNOPENED))
  1197.         Perl_warner(aTHX_ WARN_UNOPENED, "Stat on unopened file <%s>",
  1198.           GvENAME(tmpgv));
  1199.         PL_statgv = Nullgv;
  1200.         sv_setpv(PL_statname,"");
  1201.         return (PL_laststatval = -1);
  1202.     }
  1203.     }
  1204.     else {
  1205.     SV* sv = POPs;
  1206.     char *s;
  1207.     STRLEN n_a;
  1208.     PUTBACK;
  1209.     if (SvTYPE(sv) == SVt_PVGV) {
  1210.         tmpgv = (GV*)sv;
  1211.         goto do_fstat;
  1212.     }
  1213.     else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
  1214.         tmpgv = (GV*)SvRV(sv);
  1215.         goto do_fstat;
  1216.     }
  1217.  
  1218.     s = SvPV(sv, n_a);
  1219.     PL_statgv = Nullgv;
  1220.     sv_setpv(PL_statname, s);
  1221.     PL_laststype = OP_STAT;
  1222.     PL_laststatval = PerlLIO_stat(s, &PL_statcache);
  1223.     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
  1224.         Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
  1225.     return PL_laststatval;
  1226.     }
  1227. }
  1228.  
  1229. I32
  1230. Perl_my_lstat(pTHX)
  1231. {
  1232.     djSP;
  1233.     SV *sv;
  1234.     STRLEN n_a;
  1235.     if (PL_op->op_flags & OPf_REF) {
  1236.     EXTEND(SP,1);
  1237.     if (cGVOP_gv == PL_defgv) {
  1238.         if (PL_laststype != OP_LSTAT)
  1239.         Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
  1240.         return PL_laststatval;
  1241.     }
  1242.     Perl_croak(aTHX_ "You can't use -l on a filehandle");
  1243.     }
  1244.  
  1245.     PL_laststype = OP_LSTAT;
  1246.     PL_statgv = Nullgv;
  1247.     sv = POPs;
  1248.     PUTBACK;
  1249.     sv_setpv(PL_statname,SvPV(sv, n_a));
  1250.     PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
  1251.     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
  1252.     Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat");
  1253.     return PL_laststatval;
  1254. }
  1255.  
  1256. bool
  1257. Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
  1258. {
  1259.     return do_aexec5(really, mark, sp, 0, 0);
  1260. }
  1261.  
  1262. bool
  1263. Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
  1264.            int fd, int do_report)
  1265. {
  1266. #ifdef MACOS_TRADITIONAL
  1267.     Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
  1268. #else
  1269.     register char **a;
  1270.     char *tmps;
  1271.     STRLEN n_a;
  1272.  
  1273.     if (sp > mark) {
  1274.     dTHR;
  1275.     New(401,PL_Argv, sp - mark + 1, char*);
  1276.     a = PL_Argv;
  1277.     while (++mark <= sp) {
  1278.         if (*mark)
  1279.         *a++ = SvPVx(*mark, n_a);
  1280.         else
  1281.         *a++ = "";
  1282.     }
  1283.     *a = Nullch;
  1284.     if (*PL_Argv[0] != '/')    /* will execvp use PATH? */
  1285.         TAINT_ENV();        /* testing IFS here is overkill, probably */
  1286.     if (really && *(tmps = SvPV(really, n_a)))
  1287.         PerlProc_execvp(tmps,PL_Argv);
  1288.     else
  1289.         PerlProc_execvp(PL_Argv[0],PL_Argv);
  1290.     if (ckWARN(WARN_EXEC))
  1291.         Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
  1292.         PL_Argv[0], Strerror(errno));
  1293.     if (do_report) {
  1294.         int e = errno;
  1295.  
  1296.         PerlLIO_write(fd, (void*)&e, sizeof(int));
  1297.         PerlLIO_close(fd);
  1298.     }
  1299.     }
  1300.     do_execfree();
  1301. #endif
  1302.     return FALSE;
  1303. }
  1304.  
  1305. void
  1306. Perl_do_execfree(pTHX)
  1307. {
  1308.     if (PL_Argv) {
  1309.     Safefree(PL_Argv);
  1310.     PL_Argv = Null(char **);
  1311.     }
  1312.     if (PL_Cmd) {
  1313.     Safefree(PL_Cmd);
  1314.     PL_Cmd = Nullch;
  1315.     }
  1316. }
  1317.  
  1318. #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
  1319.  
  1320. bool
  1321. Perl_do_exec(pTHX_ char *cmd)
  1322. {
  1323.     return do_exec3(cmd,0,0);
  1324. }
  1325.  
  1326. bool
  1327. Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
  1328. {
  1329.     register char **a;
  1330.     register char *s;
  1331.     char flags[10];
  1332.  
  1333.     while (*cmd && isSPACE(*cmd))
  1334.     cmd++;
  1335.  
  1336.     /* save an extra exec if possible */
  1337.  
  1338. #ifdef CSH
  1339.     if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
  1340.     strcpy(flags,"-c");
  1341.     s = cmd+PL_cshlen+3;
  1342.     if (*s == 'f') {
  1343.         s++;
  1344.         strcat(flags,"f");
  1345.     }
  1346.     if (*s == ' ')
  1347.         s++;
  1348.     if (*s++ == '\'') {
  1349.         char *ncmd = s;
  1350.  
  1351.         while (*s)
  1352.         s++;
  1353.         if (s[-1] == '\n')
  1354.         *--s = '\0';
  1355.         if (s[-1] == '\'') {
  1356.         *--s = '\0';
  1357.         PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
  1358.         *s = '\'';
  1359.         return FALSE;
  1360.         }
  1361.     }
  1362.     }
  1363. #endif /* CSH */
  1364.  
  1365.     /* see if there are shell metacharacters in it */
  1366.  
  1367.     if (*cmd == '.' && isSPACE(cmd[1]))
  1368.     goto doshell;
  1369.  
  1370.     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
  1371.     goto doshell;
  1372.  
  1373.     for (s = cmd; *s && isALNUM(*s); s++) ;    /* catch VAR=val gizmo */
  1374.     if (*s == '=')
  1375.     goto doshell;
  1376.  
  1377.     for (s = cmd; *s; s++) {
  1378.     if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
  1379.         if (*s == '\n' && !s[1]) {
  1380.         *s = '\0';
  1381.         break;
  1382.         }
  1383.         /* handle the 2>&1 construct at the end */
  1384.         if (*s == '>' && s[1] == '&' && s[2] == '1'
  1385.         && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
  1386.         && (!s[3] || isSPACE(s[3])))
  1387.         {
  1388.         char *t = s + 3;
  1389.  
  1390.         while (*t && isSPACE(*t))
  1391.             ++t;
  1392.         if (!*t && (dup2(1,2) != -1)) {
  1393.             s[-2] = '\0';
  1394.             break;
  1395.         }
  1396.         }
  1397.       doshell:
  1398.         PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
  1399.         return FALSE;
  1400.     }
  1401.     }
  1402.  
  1403.     New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
  1404.     PL_Cmd = savepvn(cmd, s-cmd);
  1405.     a = PL_Argv;
  1406.     for (s = PL_Cmd; *s;) {
  1407.     while (*s && isSPACE(*s)) s++;
  1408.     if (*s)
  1409.         *(a++) = s;
  1410.     while (*s && !isSPACE(*s)) s++;
  1411.     if (*s)
  1412.         *s++ = '\0';
  1413.     }
  1414.     *a = Nullch;
  1415.     if (PL_Argv[0]) {
  1416.     PerlProc_execvp(PL_Argv[0],PL_Argv);
  1417.     if (errno == ENOEXEC) {        /* for system V NIH syndrome */
  1418.         do_execfree();
  1419.         goto doshell;
  1420.     }
  1421.     {
  1422.         dTHR;
  1423.         int e = errno;
  1424.  
  1425.         if (ckWARN(WARN_EXEC))
  1426.         Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
  1427.             PL_Argv[0], Strerror(errno));
  1428.         if (do_report) {
  1429.         PerlLIO_write(fd, (void*)&e, sizeof(int));
  1430.         PerlLIO_close(fd);
  1431.         }
  1432.     }
  1433.     }
  1434.     do_execfree();
  1435.     return FALSE;
  1436. }
  1437.  
  1438. #endif /* OS2 || WIN32 */
  1439.  
  1440. I32
  1441. Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
  1442. {
  1443.     dTHR;
  1444.     register I32 val;
  1445.     register I32 val2;
  1446.     register I32 tot = 0;
  1447.     char *what;
  1448.     char *s;
  1449.     SV **oldmark = mark;
  1450.     STRLEN n_a;
  1451.  
  1452. #define APPLY_TAINT_PROPER() \
  1453.     STMT_START {                            \
  1454.     if (PL_tainted) { TAINT_PROPER(what); }                \
  1455.     } STMT_END
  1456.  
  1457.     /* This is a first heuristic; it doesn't catch tainting magic. */
  1458.     if (PL_tainting) {
  1459.     while (++mark <= sp) {
  1460.         if (SvTAINTED(*mark)) {
  1461.         TAINT;
  1462.         break;
  1463.         }
  1464.     }
  1465.     mark = oldmark;
  1466.     }
  1467.     switch (type) {
  1468.     case OP_CHMOD:
  1469.     what = "chmod";
  1470.     APPLY_TAINT_PROPER();
  1471.     if (++mark <= sp) {
  1472.         val = SvIVx(*mark);
  1473.         APPLY_TAINT_PROPER();
  1474.         tot = sp - mark;
  1475.         while (++mark <= sp) {
  1476.         char *name = SvPVx(*mark, n_a);
  1477.         APPLY_TAINT_PROPER();
  1478.         if (PerlLIO_chmod(name, val))
  1479.             tot--;
  1480.         }
  1481.     }
  1482.     break;
  1483. #ifdef HAS_CHOWN
  1484.     case OP_CHOWN:
  1485.     what = "chown";
  1486.     APPLY_TAINT_PROPER();
  1487.     if (sp - mark > 2) {
  1488.         val = SvIVx(*++mark);
  1489.         val2 = SvIVx(*++mark);
  1490.         APPLY_TAINT_PROPER();
  1491.         tot = sp - mark;
  1492.         while (++mark <= sp) {
  1493.         char *name = SvPVx(*mark, n_a);
  1494.         APPLY_TAINT_PROPER();
  1495.         if (PerlLIO_chown(name, val, val2))
  1496.             tot--;
  1497.         }
  1498.     }
  1499.     break;
  1500. #endif
  1501. /* 
  1502. XXX Should we make lchown() directly available from perl?
  1503. For now, we'll let Configure test for HAS_LCHOWN, but do
  1504. nothing in the core.
  1505.     --AD  5/1998
  1506. */
  1507. #ifdef HAS_KILL
  1508.     case OP_KILL:
  1509.     what = "kill";
  1510.     APPLY_TAINT_PROPER();
  1511.     if (mark == sp)
  1512.         break;
  1513.     s = SvPVx(*++mark, n_a);
  1514.     if (isUPPER(*s)) {
  1515.         if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
  1516.         s += 3;
  1517.         if (!(val = whichsig(s)))
  1518.         Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
  1519.     }
  1520.     else
  1521.         val = SvIVx(*mark);
  1522.     APPLY_TAINT_PROPER();
  1523.     tot = sp - mark;
  1524. #ifdef VMS
  1525.     /* kill() doesn't do process groups (job trees?) under VMS */
  1526.     if (val < 0) val = -val;
  1527.     if (val == SIGKILL) {
  1528. #        include <starlet.h>
  1529.         /* Use native sys$delprc() to insure that target process is
  1530.          * deleted; supervisor-mode images don't pay attention to
  1531.          * CRTL's emulation of Unix-style signals and kill()
  1532.          */
  1533.         while (++mark <= sp) {
  1534.         I32 proc = SvIVx(*mark);
  1535.         register unsigned long int __vmssts;
  1536.         APPLY_TAINT_PROPER();
  1537.         if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
  1538.             tot--;
  1539.             switch (__vmssts) {
  1540.             case SS$_NONEXPR:
  1541.             case SS$_NOSUCHNODE:
  1542.                 SETERRNO(ESRCH,__vmssts);
  1543.                 break;
  1544.             case SS$_NOPRIV:
  1545.                 SETERRNO(EPERM,__vmssts);
  1546.                 break;
  1547.             default:
  1548.                 SETERRNO(EVMSERR,__vmssts);
  1549.             }
  1550.         }
  1551.         }
  1552.         break;
  1553.     }
  1554. #endif
  1555.     if (val < 0) {
  1556.         val = -val;
  1557.         while (++mark <= sp) {
  1558.         I32 proc = SvIVx(*mark);
  1559.         APPLY_TAINT_PROPER();
  1560. #ifdef HAS_KILLPG
  1561.         if (PerlProc_killpg(proc,val))    /* BSD */
  1562. #else
  1563.         if (PerlProc_kill(-proc,val))    /* SYSV */
  1564. #endif
  1565.             tot--;
  1566.         }
  1567.     }
  1568.     else {
  1569.         while (++mark <= sp) {
  1570.         I32 proc = SvIVx(*mark);
  1571.         APPLY_TAINT_PROPER();
  1572.         if (PerlProc_kill(proc, val))
  1573.             tot--;
  1574.         }
  1575.     }
  1576.     break;
  1577. #endif
  1578.     case OP_UNLINK:
  1579.     what = "unlink";
  1580.     APPLY_TAINT_PROPER();
  1581.     tot = sp - mark;
  1582.     while (++mark <= sp) {
  1583.         s = SvPVx(*mark, n_a);
  1584.         APPLY_TAINT_PROPER();
  1585.         if (PL_euid || PL_unsafe) {
  1586.         if (UNLINK(s))
  1587.             tot--;
  1588.         }
  1589.         else {    /* don't let root wipe out directories without -U */
  1590.         if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
  1591.             tot--;
  1592.         else {
  1593.             if (UNLINK(s))
  1594.             tot--;
  1595.         }
  1596.         }
  1597.     }
  1598.     break;
  1599. #ifdef HAS_UTIME
  1600.     case OP_UTIME:
  1601.     what = "utime";
  1602.     APPLY_TAINT_PROPER();
  1603.     if (sp - mark > 2) {
  1604. #if defined(I_UTIME) || defined(VMS)
  1605.         struct utimbuf utbuf;
  1606. #else
  1607.         struct {
  1608.         Time_t    actime;
  1609.         Time_t    modtime;
  1610.         } utbuf;
  1611. #endif
  1612.  
  1613.         Zero(&utbuf, sizeof utbuf, char);
  1614. #ifdef BIG_TIME
  1615.         utbuf.actime = (Time_t)SvNVx(*++mark);    /* time accessed */
  1616.         utbuf.modtime = (Time_t)SvNVx(*++mark);    /* time modified */
  1617. #else
  1618.         utbuf.actime = (Time_t)SvIVx(*++mark);    /* time accessed */
  1619.         utbuf.modtime = (Time_t)SvIVx(*++mark);    /* time modified */
  1620. #endif
  1621.         APPLY_TAINT_PROPER();
  1622.         tot = sp - mark;
  1623.         while (++mark <= sp) {
  1624.         char *name = SvPVx(*mark, n_a);
  1625.         APPLY_TAINT_PROPER();
  1626.         if (PerlLIO_utime(name, &utbuf))
  1627.             tot--;
  1628.         }
  1629.     }
  1630.     else
  1631.         tot = 0;
  1632.     break;
  1633. #endif
  1634.     }
  1635.     return tot;
  1636.  
  1637. #undef APPLY_TAINT_PROPER
  1638. }
  1639.  
  1640. /* Do the permissions allow some operation?  Assumes statcache already set. */
  1641. #ifndef VMS /* VMS' cando is in vms.c */
  1642. bool
  1643. Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
  1644. /* Note: we use `effective' both for uids and gids.
  1645.  * Here we are betting on Uid_t being equal or wider than Gid_t.  */
  1646. {
  1647. #ifdef DOSISH
  1648.     /* [Comments and code from Len Reed]
  1649.      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
  1650.      * to write-protected files.  The execute permission bit is set
  1651.      * by the Miscrosoft C library stat() function for the following:
  1652.      *        .exe files
  1653.      *        .com files
  1654.      *        .bat files
  1655.      *        directories
  1656.      * All files and directories are readable.
  1657.      * Directories and special files, e.g. "CON", cannot be
  1658.      * write-protected.
  1659.      * [Comment by Tom Dinger -- a directory can have the write-protect
  1660.      *        bit set in the file system, but DOS permits changes to
  1661.      *        the directory anyway.  In addition, all bets are off
  1662.      *        here for networked software, such as Novell and
  1663.      *        Sun's PC-NFS.]
  1664.      */
  1665.  
  1666.      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
  1667.       * too so it will actually look into the files for magic numbers
  1668.       */
  1669.      return (mode & statbufp->st_mode) ? TRUE : FALSE;
  1670.  
  1671. #else /* ! DOSISH */
  1672.     if ((effective ? PL_euid : PL_uid) == 0) {    /* root is special */
  1673.     if (mode == S_IXUSR) {
  1674.         if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
  1675.         return TRUE;
  1676.     }
  1677.     else
  1678.         return TRUE;        /* root reads and writes anything */
  1679.     return FALSE;
  1680.     }
  1681.     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
  1682.     if (statbufp->st_mode & mode)
  1683.         return TRUE;    /* ok as "user" */
  1684.     }
  1685.     else if (ingroup(statbufp->st_gid,effective)) {
  1686.     if (statbufp->st_mode & mode >> 3)
  1687.         return TRUE;    /* ok as "group" */
  1688.     }
  1689.     else if (statbufp->st_mode & mode >> 6)
  1690.     return TRUE;    /* ok as "other" */
  1691.     return FALSE;
  1692. #endif /* ! DOSISH */
  1693. }
  1694. #endif /* ! VMS */
  1695.  
  1696. bool
  1697. Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
  1698. {
  1699. #ifdef MACOS_TRADITIONAL
  1700.     /* This is simply not correct for AppleShare, but fix it yerself. */
  1701.     return TRUE;
  1702. #else
  1703.     if (testgid == (effective ? PL_egid : PL_gid))
  1704.     return TRUE;
  1705. #ifdef HAS_GETGROUPS
  1706. #ifndef NGROUPS
  1707. #define NGROUPS 32
  1708. #endif
  1709.     {
  1710.     Groups_t gary[NGROUPS];
  1711.     I32 anum;
  1712.  
  1713.     anum = getgroups(NGROUPS,gary);
  1714.     while (--anum >= 0)
  1715.         if (gary[anum] == testgid)
  1716.         return TRUE;
  1717.     }
  1718. #endif
  1719.     return FALSE;
  1720. #endif
  1721. }
  1722.  
  1723. #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  1724.  
  1725. I32
  1726. Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
  1727. {
  1728.     dTHR;
  1729.     key_t key;
  1730.     I32 n, flags;
  1731.  
  1732.     key = (key_t)SvNVx(*++mark);
  1733.     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
  1734.     flags = SvIVx(*++mark);
  1735.     SETERRNO(0,0);
  1736.     switch (optype)
  1737.     {
  1738. #ifdef HAS_MSG
  1739.     case OP_MSGGET:
  1740.     return msgget(key, flags);
  1741. #endif
  1742. #ifdef HAS_SEM
  1743.     case OP_SEMGET:
  1744.     return semget(key, n, flags);
  1745. #endif
  1746. #ifdef HAS_SHM
  1747.     case OP_SHMGET:
  1748.     return shmget(key, n, flags);
  1749. #endif
  1750. #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
  1751.     default:
  1752.     Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
  1753. #endif
  1754.     }
  1755.     return -1;            /* should never happen */
  1756. }
  1757.  
  1758. I32
  1759. Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
  1760. {
  1761.     dTHR;
  1762.     SV *astr;
  1763.     char *a;
  1764.     I32 id, n, cmd, infosize, getinfo;
  1765.     I32 ret = -1;
  1766.  
  1767.     id = SvIVx(*++mark);
  1768.     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
  1769.     cmd = SvIVx(*++mark);
  1770.     astr = *++mark;
  1771.     infosize = 0;
  1772.     getinfo = (cmd == IPC_STAT);
  1773.  
  1774.     switch (optype)
  1775.     {
  1776. #ifdef HAS_MSG
  1777.     case OP_MSGCTL:
  1778.     if (cmd == IPC_STAT || cmd == IPC_SET)
  1779.         infosize = sizeof(struct msqid_ds);
  1780.     break;
  1781. #endif
  1782. #ifdef HAS_SHM
  1783.     case OP_SHMCTL:
  1784.     if (cmd == IPC_STAT || cmd == IPC_SET)
  1785.         infosize = sizeof(struct shmid_ds);
  1786.     break;
  1787. #endif
  1788. #ifdef HAS_SEM
  1789.     case OP_SEMCTL:
  1790. #ifdef Semctl
  1791.     if (cmd == IPC_STAT || cmd == IPC_SET)
  1792.         infosize = sizeof(struct semid_ds);
  1793.     else if (cmd == GETALL || cmd == SETALL)
  1794.     {
  1795.         struct semid_ds semds;
  1796.         union semun semun;
  1797. #ifdef EXTRA_F_IN_SEMUN_BUF
  1798.             semun.buff = &semds;
  1799. #else
  1800.             semun.buf = &semds;
  1801. #endif
  1802.         getinfo = (cmd == GETALL);
  1803.         if (Semctl(id, 0, IPC_STAT, semun) == -1)
  1804.         return -1;
  1805.         infosize = semds.sem_nsems * sizeof(short);
  1806.         /* "short" is technically wrong but much more portable
  1807.            than guessing about u_?short(_t)? */
  1808.     }
  1809. #else
  1810.     Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
  1811. #endif
  1812.     break;
  1813. #endif
  1814. #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
  1815.     default:
  1816.     Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
  1817. #endif
  1818.     }
  1819.  
  1820.     if (infosize)
  1821.     {
  1822.     STRLEN len;
  1823.     if (getinfo)
  1824.     {
  1825.         SvPV_force(astr, len);
  1826.         a = SvGROW(astr, infosize+1);
  1827.     }
  1828.     else
  1829.     {
  1830.         a = SvPV(astr, len);
  1831.         if (len != infosize)
  1832.         Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
  1833.               PL_op_desc[optype],
  1834.               (unsigned long)len,
  1835.               (long)infosize);
  1836.     }
  1837.     }
  1838.     else
  1839.     {
  1840.     IV i = SvIV(astr);
  1841.     a = INT2PTR(char *,i);        /* ouch */
  1842.     }
  1843.     SETERRNO(0,0);
  1844.     switch (optype)
  1845.     {
  1846. #ifdef HAS_MSG
  1847.     case OP_MSGCTL:
  1848.     ret = msgctl(id, cmd, (struct msqid_ds *)a);
  1849.     break;
  1850. #endif
  1851. #ifdef HAS_SEM
  1852.     case OP_SEMCTL: {
  1853. #ifdef Semctl
  1854.             union semun unsemds;
  1855.  
  1856. #ifdef EXTRA_F_IN_SEMUN_BUF
  1857.             unsemds.buff = (struct semid_ds *)a;
  1858. #else
  1859.             unsemds.buf = (struct semid_ds *)a;
  1860. #endif
  1861.         ret = Semctl(id, n, cmd, unsemds);
  1862. #else
  1863.         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
  1864. #endif
  1865.         }
  1866.     break;
  1867. #endif
  1868. #ifdef HAS_SHM
  1869.     case OP_SHMCTL:
  1870.     ret = shmctl(id, cmd, (struct shmid_ds *)a);
  1871.     break;
  1872. #endif
  1873.     }
  1874.     if (getinfo && ret >= 0) {
  1875.     SvCUR_set(astr, infosize);
  1876.     *SvEND(astr) = '\0';
  1877.     SvSETMAGIC(astr);
  1878.     }
  1879.     return ret;
  1880. }
  1881.  
  1882. I32
  1883. Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
  1884. {
  1885. #ifdef HAS_MSG
  1886.     dTHR;
  1887.     SV *mstr;
  1888.     char *mbuf;
  1889.     I32 id, msize, flags;
  1890.     STRLEN len;
  1891.  
  1892.     id = SvIVx(*++mark);
  1893.     mstr = *++mark;
  1894.     flags = SvIVx(*++mark);
  1895.     mbuf = SvPV(mstr, len);
  1896.     if ((msize = len - sizeof(long)) < 0)
  1897.     Perl_croak(aTHX_ "Arg too short for msgsnd");
  1898.     SETERRNO(0,0);
  1899.     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
  1900. #else
  1901.     Perl_croak(aTHX_ "msgsnd not implemented");
  1902. #endif
  1903. }
  1904.  
  1905. I32
  1906. Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
  1907. {
  1908. #ifdef HAS_MSG
  1909.     dTHR;
  1910.     SV *mstr;
  1911.     char *mbuf;
  1912.     long mtype;
  1913.     I32 id, msize, flags, ret;
  1914.     STRLEN len;
  1915.  
  1916.     id = SvIVx(*++mark);
  1917.     mstr = *++mark;
  1918.     msize = SvIVx(*++mark);
  1919.     mtype = (long)SvIVx(*++mark);
  1920.     flags = SvIVx(*++mark);
  1921.     SvPV_force(mstr, len);
  1922.     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
  1923.     
  1924.     SETERRNO(0,0);
  1925.     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
  1926.     if (ret >= 0) {
  1927.     SvCUR_set(mstr, sizeof(long)+ret);
  1928.     *SvEND(mstr) = '\0';
  1929. #ifndef INCOMPLETE_TAINTS
  1930.     /* who knows who has been playing with this message? */
  1931.     SvTAINTED_on(mstr);
  1932. #endif
  1933.     }
  1934.     return ret;
  1935. #else
  1936.     Perl_croak(aTHX_ "msgrcv not implemented");
  1937. #endif
  1938. }
  1939.  
  1940. I32
  1941. Perl_do_semop(pTHX_ SV **mark, SV **sp)
  1942. {
  1943. #ifdef HAS_SEM
  1944.     dTHR;
  1945.     SV *opstr;
  1946.     char *opbuf;
  1947.     I32 id;
  1948.     STRLEN opsize;
  1949.  
  1950.     id = SvIVx(*++mark);
  1951.     opstr = *++mark;
  1952.     opbuf = SvPV(opstr, opsize);
  1953.     if (opsize < sizeof(struct sembuf)
  1954.     || (opsize % sizeof(struct sembuf)) != 0) {
  1955.     SETERRNO(EINVAL,LIB$_INVARG);
  1956.     return -1;
  1957.     }
  1958.     SETERRNO(0,0);
  1959.     return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
  1960. #else
  1961.     Perl_croak(aTHX_ "semop not implemented");
  1962. #endif
  1963. }
  1964.  
  1965. I32
  1966. Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
  1967. {
  1968. #ifdef HAS_SHM
  1969.     dTHR;
  1970.     SV *mstr;
  1971.     char *mbuf, *shm;
  1972.     I32 id, mpos, msize;
  1973.     STRLEN len;
  1974.     struct shmid_ds shmds;
  1975.  
  1976.     id = SvIVx(*++mark);
  1977.     mstr = *++mark;
  1978.     mpos = SvIVx(*++mark);
  1979.     msize = SvIVx(*++mark);
  1980.     SETERRNO(0,0);
  1981.     if (shmctl(id, IPC_STAT, &shmds) == -1)
  1982.     return -1;
  1983.     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
  1984.     SETERRNO(EFAULT,SS$_ACCVIO);        /* can't do as caller requested */
  1985.     return -1;
  1986.     }
  1987.     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
  1988.     if (shm == (char *)-1)    /* I hate System V IPC, I really do */
  1989.     return -1;
  1990.     if (optype == OP_SHMREAD) {
  1991.     /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
  1992.     if (! SvOK(mstr))
  1993.         sv_setpvn(mstr, "", 0);
  1994.     SvPV_force(mstr, len);
  1995.     mbuf = SvGROW(mstr, msize+1);
  1996.  
  1997.     Copy(shm + mpos, mbuf, msize, char);
  1998.     SvCUR_set(mstr, msize);
  1999.     *SvEND(mstr) = '\0';
  2000.     SvSETMAGIC(mstr);
  2001. #ifndef INCOMPLETE_TAINTS
  2002.     /* who knows who has been playing with this shared memory? */
  2003.     SvTAINTED_on(mstr);
  2004. #endif
  2005.     }
  2006.     else {
  2007.     I32 n;
  2008.  
  2009.     mbuf = SvPV(mstr, len);
  2010.     if ((n = len) > msize)
  2011.         n = msize;
  2012.     Copy(mbuf, shm + mpos, n, char);
  2013.     if (n < msize)
  2014.         memzero(shm + mpos + n, msize - n);
  2015.     }
  2016.     return shmdt(shm);
  2017. #else
  2018.     Perl_croak(aTHX_ "shm I/O not implemented");
  2019. #endif
  2020. }
  2021.  
  2022. #endif /* SYSV IPC */
  2023.  
  2024.