This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Minuscule code cleanup.
[perl5.git] / doio.c
1 /*    doio.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * "Far below them they saw the white waters pour into a foaming bowl, and
13  * then swirl darkly about a deep oval basin in the rocks, until they found
14  * their way out again through a narrow gate, and flowed away, fuming and
15  * chattering, into calmer and more level reaches."
16  */
17
18 #include "EXTERN.h"
19 #define PERL_IN_DOIO_C
20 #include "perl.h"
21
22 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
23 #ifndef HAS_SEM
24 #include <sys/ipc.h>
25 #endif
26 #ifdef HAS_MSG
27 #include <sys/msg.h>
28 #endif
29 #ifdef HAS_SHM
30 #include <sys/shm.h>
31 # ifndef HAS_SHMAT_PROTOTYPE
32     extern Shmat_t shmat (int, char *, int);
33 # endif
34 #endif
35 #endif
36
37 #ifdef I_UTIME
38 #  if defined(_MSC_VER) || defined(__MINGW32__)
39 #    include <sys/utime.h>
40 #  else
41 #    include <utime.h>
42 #  endif
43 #endif
44
45 #ifdef O_EXCL
46 #  define OPEN_EXCL O_EXCL
47 #else
48 #  define OPEN_EXCL 0
49 #endif
50
51 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
52 #include <signal.h>
53 #endif
54
55 bool
56 Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
57              int rawmode, int rawperm, PerlIO *supplied_fp)
58 {
59     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
60                     supplied_fp, (SV **) NULL, 0);
61 }
62
63 bool
64 Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
65               int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
66               I32 num_svs)
67 {
68     return do_openn(gv, name, len, as_raw, rawmode, rawperm,
69                     supplied_fp, &svs, 1);
70 }
71
72 bool
73 Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
74               int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
75               I32 num_svs)
76 {
77     register IO *io = GvIOn(gv);
78     PerlIO *saveifp = Nullfp;
79     PerlIO *saveofp = Nullfp;
80     int savefd = -1;
81     char savetype = IoTYPE_CLOSED;
82     int writing = 0;
83     PerlIO *fp;
84     int fd;
85     int result;
86     bool was_fdopen = FALSE;
87     bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
88     char *type  = NULL;
89     char mode[8];               /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
90     SV *namesv;
91
92     Zero(mode,sizeof(mode),char);
93     PL_forkprocess = 1;         /* assume true if no fork */
94
95     /* Collect default raw/crlf info from the op */
96     if (PL_op && PL_op->op_type == OP_OPEN) {
97         /* set up IO layers */
98         U8 flags = PL_op->op_private;
99         in_raw = (flags & OPpOPEN_IN_RAW);
100         in_crlf = (flags & OPpOPEN_IN_CRLF);
101         out_raw = (flags & OPpOPEN_OUT_RAW);
102         out_crlf = (flags & OPpOPEN_OUT_CRLF);
103     }
104
105     /* If currently open - close before we re-open */
106     if (IoIFP(io)) {
107         fd = PerlIO_fileno(IoIFP(io));
108         if (IoTYPE(io) == IoTYPE_STD) {
109             /* This is a clone of one of STD* handles */
110             result = 0;
111         }
112         else if (fd >= 0 && fd <= PL_maxsysfd) {
113             /* This is one of the original STD* handles */
114             saveifp  = IoIFP(io);
115             saveofp  = IoOFP(io);
116             savetype = IoTYPE(io);
117             savefd   = fd;
118             result   = 0;
119         }
120         else if (IoTYPE(io) == IoTYPE_PIPE)
121             result = PerlProc_pclose(IoIFP(io));
122         else if (IoIFP(io) != IoOFP(io)) {
123             if (IoOFP(io)) {
124                 result = PerlIO_close(IoOFP(io));
125                 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
126             }
127             else
128                 result = PerlIO_close(IoIFP(io));
129         }
130         else
131             result = PerlIO_close(IoIFP(io));
132         if (result == EOF && fd > PL_maxsysfd) {
133             /* Why is this not Perl_warn*() call ? */
134             PerlIO_printf(Perl_error_log,
135                           "Warning: unable to close filehandle %s properly.\n",
136                           GvENAME(gv));
137         }
138         IoOFP(io) = IoIFP(io) = Nullfp;
139     }
140
141     if (as_raw) {
142         /* sysopen style args, i.e. integer mode and permissions */
143         STRLEN ix = 0;
144         int appendtrunc =
145              0
146 #ifdef O_APPEND /* Not fully portable. */
147              |O_APPEND
148 #endif
149 #ifdef O_TRUNC  /* Not fully portable. */
150              |O_TRUNC
151 #endif
152              ;
153         int modifyingmode =
154              O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
155         int ismodifying;
156
157         if (num_svs != 0) {
158              Perl_croak(aTHX_ "panic: sysopen with multiple args");
159         }
160         /* It's not always
161
162            O_RDONLY 0
163            O_WRONLY 1
164            O_RDWR   2
165
166            It might be (in OS/390 and Mac OS Classic it is)
167
168            O_WRONLY 1
169            O_RDONLY 2
170            O_RDWR   3
171
172            This means that simple & with O_RDWR would look
173            like O_RDONLY is present.  Therefore we have to
174            be more careful.
175         */
176         if ((ismodifying = (rawmode & modifyingmode))) {
177              if ((ismodifying & O_WRONLY) == O_WRONLY ||
178                  (ismodifying & O_RDWR)   == O_RDWR   ||
179                  (ismodifying & (O_CREAT|appendtrunc)))
180                   TAINT_PROPER("sysopen");
181         }
182         mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */
183
184 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
185         rawmode |= O_LARGEFILE; /* Transparently largefiley. */
186 #endif
187
188         IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
189
190         namesv = sv_2mortal(newSVpvn(name,strlen(name)));
191         num_svs = 1;
192         svp = &namesv;
193         type = Nullch;
194         fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp);
195     }
196     else {
197         /* Regular (non-sys) open */
198         char *oname = name;
199         STRLEN olen = len;
200         char *tend;
201         int dodup = 0;
202         PerlIO *that_fp = NULL;
203
204         type = savepvn(name, len);
205         tend = type+len;
206         SAVEFREEPV(type);
207
208         /* Lose leading and trailing white space */
209         /*SUPPRESS 530*/
210         for (; isSPACE(*type); type++) ;
211         while (tend > type && isSPACE(tend[-1]))
212             *--tend = '\0';
213
214         if (num_svs) {
215             /* New style explicit name, type is just mode and layer info */
216             STRLEN l = 0;
217 #ifdef USE_STDIO
218             if (SvROK(*svp) && !strchr(name,'&')) {
219                 if (ckWARN(WARN_IO))
220                     Perl_warner(aTHX_ packWARN(WARN_IO),
221                             "Can't open a reference");
222                 SETERRNO(EINVAL, LIB_INVARG);
223                 goto say_false;
224             }
225 #endif /* USE_STDIO */
226             name = SvOK(*svp) ? SvPV(*svp, l) : "";
227             len = (I32)l;
228             name = savepvn(name, len);
229             SAVEFREEPV(name);
230         }
231         else {
232             name = type;
233             len  = tend-type;
234         }
235         IoTYPE(io) = *type;
236         if ((*type == IoTYPE_RDWR) && /* scary */
237            (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
238             ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
239             TAINT_PROPER("open");
240             mode[1] = *type++;
241             writing = 1;
242         }
243
244         if (*type == IoTYPE_PIPE) {
245             if (num_svs) {
246                 if (type[1] != IoTYPE_STD) {
247                   unknown_open_mode:
248                     Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
249                 }
250                 type++;
251             }
252             /*SUPPRESS 530*/
253             for (type++; isSPACE(*type); type++) ;
254             if (!num_svs) {
255                 name = type;
256                 len = tend-type;
257             }
258             if (*name == '\0') {
259                 /* command is missing 19990114 */
260                 if (ckWARN(WARN_PIPE))
261                     Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
262                 errno = EPIPE;
263                 goto say_false;
264             }
265             if (strNE(name,"-") || num_svs)
266                 TAINT_ENV();
267             TAINT_PROPER("piped open");
268             if (!num_svs && name[len-1] == '|') {
269                 name[--len] = '\0' ;
270                 if (ckWARN(WARN_PIPE))
271                     Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
272             }
273             mode[0] = 'w';
274             writing = 1;
275             if (out_raw)
276                 strcat(mode, "b");
277             else if (out_crlf)
278                 strcat(mode, "t");
279             if (num_svs > 1) {
280                 fp = PerlProc_popen_list(mode, num_svs, svp);
281             }
282             else {
283                 fp = PerlProc_popen(name,mode);
284             }
285             if (num_svs) {
286                 if (*type) {
287                     if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
288                         goto say_false;
289                     }
290                 }
291             }
292         } /* IoTYPE_PIPE */
293         else if (*type == IoTYPE_WRONLY) {
294             TAINT_PROPER("open");
295             type++;
296             if (*type == IoTYPE_WRONLY) {
297                 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
298                 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
299                 type++;
300             }
301             else {
302                 mode[0] = 'w';
303             }
304             writing = 1;
305
306             if (out_raw)
307                 strcat(mode, "b");
308             else if (out_crlf)
309                 strcat(mode, "t");
310
311             if (*type == '&') {
312               duplicity:
313                 dodup = PERLIO_DUP_FD;
314                 type++;
315                 if (*type == '=') {
316                     dodup = 0;
317                     type++;
318                 }
319                 if (!num_svs && !*type && supplied_fp) {
320                     /* "<+&" etc. is used by typemaps */
321                     fp = supplied_fp;
322                 }
323                 else {
324                     if (num_svs > 1) {
325                         Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
326                     }
327                     /*SUPPRESS 530*/
328                     for (; isSPACE(*type); type++) ;
329                     if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
330                         fd = SvUV(*svp);
331                         num_svs = 0;
332                     }
333                     else if (isDIGIT(*type)) {
334                         fd = atoi(type);
335                     }
336                     else {
337                         IO* thatio;
338                         if (num_svs) {
339                             thatio = sv_2io(*svp);
340                         }
341                         else {
342                             GV *thatgv;
343                             thatgv = gv_fetchpv(type,FALSE,SVt_PVIO);
344                             thatio = GvIO(thatgv);
345                         }
346                         if (!thatio) {
347 #ifdef EINVAL
348                             SETERRNO(EINVAL,SS_IVCHAN);
349 #endif
350                             goto say_false;
351                         }
352                         if ((that_fp = IoIFP(thatio))) {
353                             /* Flush stdio buffer before dup. --mjd
354                              * Unfortunately SEEK_CURing 0 seems to
355                              * be optimized away on most platforms;
356                              * only Solaris and Linux seem to flush
357                              * on that. --jhi */
358 #ifdef USE_SFIO
359                             /* sfio fails to clear error on next
360                                sfwrite, contrary to documentation.
361                                -- Nick Clark */
362                             if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1)
363                                 PerlIO_clearerr(that_fp);
364 #endif
365                             /* On the other hand, do all platforms
366                              * take gracefully to flushing a read-only
367                              * filehandle?  Perhaps we should do
368                              * fsetpos(src)+fgetpos(dst)?  --nik */
369                             PerlIO_flush(that_fp);
370                             fd = PerlIO_fileno(that_fp);
371                             /* When dup()ing STDIN, STDOUT or STDERR
372                              * explicitly set appropriate access mode */
373                             if (that_fp == PerlIO_stdout()
374                                 || that_fp == PerlIO_stderr())
375                                 IoTYPE(io) = IoTYPE_WRONLY;
376                             else if (that_fp == PerlIO_stdin())
377                                 IoTYPE(io) = IoTYPE_RDONLY;
378                             /* When dup()ing a socket, say result is
379                              * one as well */
380                             else if (IoTYPE(thatio) == IoTYPE_SOCKET)
381                                 IoTYPE(io) = IoTYPE_SOCKET;
382                         }
383                         else
384                             fd = -1;
385                     }
386                     if (!num_svs)
387                         type = Nullch;
388                     if (that_fp) {
389                         fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
390                     }
391                     else {
392                         if (dodup)
393                             fd = PerlLIO_dup(fd);
394                         else
395                             was_fdopen = TRUE;
396                         if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
397                             if (dodup)
398                                 PerlLIO_close(fd);
399                         }
400                     }
401                 }
402             } /* & */
403             else {
404                 /*SUPPRESS 530*/
405                 for (; isSPACE(*type); type++) ;
406                 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
407                     /*SUPPRESS 530*/
408                     type++;
409                     fp = PerlIO_stdout();
410                     IoTYPE(io) = IoTYPE_STD;
411                     if (num_svs > 1) {
412                         Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
413                     }
414                 }
415                 else  {
416                     if (!num_svs) {
417                         namesv = sv_2mortal(newSVpvn(type,strlen(type)));
418                         num_svs = 1;
419                         svp = &namesv;
420                         type = Nullch;
421                     }
422                     fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
423                 }
424             } /* !& */
425         } /* IoTYPE_WRONLY */
426         else if (*type == IoTYPE_RDONLY) {
427             /*SUPPRESS 530*/
428             for (type++; isSPACE(*type); type++) ;
429             mode[0] = 'r';
430             if (in_raw)
431                 strcat(mode, "b");
432             else if (in_crlf)
433                 strcat(mode, "t");
434
435             if (*type == '&') {
436                 goto duplicity;
437             }
438             if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
439                 /*SUPPRESS 530*/
440                 type++;
441                 fp = PerlIO_stdin();
442                 IoTYPE(io) = IoTYPE_STD;
443                 if (num_svs > 1) {
444                     Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
445                 }
446             }
447             else {
448                 if (!num_svs) {
449                     namesv = sv_2mortal(newSVpvn(type,strlen(type)));
450                     num_svs = 1;
451                     svp = &namesv;
452                     type = Nullch;
453                 }
454                 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
455             }
456         } /* IoTYPE_RDONLY */
457         else if ((num_svs && /* '-|...' or '...|' */
458                   type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
459                  (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
460             if (num_svs) {
461                 type += 2;   /* skip over '-|' */
462             }
463             else {
464                 *--tend = '\0';
465                 while (tend > type && isSPACE(tend[-1]))
466                     *--tend = '\0';
467                 /*SUPPRESS 530*/
468                 for (; isSPACE(*type); type++) ;
469                 name = type;
470                 len  = tend-type;
471             }
472             if (*name == '\0') {
473                 /* command is missing 19990114 */
474                 if (ckWARN(WARN_PIPE))
475                     Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
476                 errno = EPIPE;
477                 goto say_false;
478             }
479             if (strNE(name,"-") || num_svs)
480                 TAINT_ENV();
481             TAINT_PROPER("piped open");
482             mode[0] = 'r';
483             if (in_raw)
484                 strcat(mode, "b");
485             else if (in_crlf)
486                 strcat(mode, "t");
487             if (num_svs > 1) {
488                 fp = PerlProc_popen_list(mode,num_svs,svp);
489             }
490             else {
491                 fp = PerlProc_popen(name,mode);
492             }
493             IoTYPE(io) = IoTYPE_PIPE;
494             if (num_svs) {
495                 for (; isSPACE(*type); type++) ;
496                 if (*type) {
497                     if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
498                         goto say_false;
499                     }
500                 }
501             }
502         }
503         else { /* layer(Args) */
504             if (num_svs)
505                 goto unknown_open_mode;
506             name = type;
507             IoTYPE(io) = IoTYPE_RDONLY;
508             /*SUPPRESS 530*/
509             for (; isSPACE(*name); name++) ;
510             mode[0] = 'r';
511             if (in_raw)
512                 strcat(mode, "b");
513             else if (in_crlf)
514                 strcat(mode, "t");
515             if (strEQ(name,"-")) {
516                 fp = PerlIO_stdin();
517                 IoTYPE(io) = IoTYPE_STD;
518             }
519             else {
520                 if (!num_svs) {
521                     namesv = sv_2mortal(newSVpvn(type,strlen(type)));
522                     num_svs = 1;
523                     svp = &namesv;
524                     type = Nullch;
525                 }
526                 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
527             }
528         }
529     }
530     if (!fp) {
531         if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
532             Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
533         goto say_false;
534     }
535
536     if (ckWARN(WARN_IO)) {
537         if ((IoTYPE(io) == IoTYPE_RDONLY) &&
538             (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
539                 Perl_warner(aTHX_ packWARN(WARN_IO),
540                             "Filehandle STD%s reopened as %s only for input",
541                             ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
542                             GvENAME(gv));
543         }
544         else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
545                 Perl_warner(aTHX_ packWARN(WARN_IO),
546                             "Filehandle STDIN reopened as %s only for output",
547                             GvENAME(gv));
548         }
549     }
550
551     fd = PerlIO_fileno(fp);
552     /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
553      * socket - this covers PerlIO::scalar - otherwise unless we "know" the
554      * type probe for socket-ness.
555      */
556     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
557         if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
558             /* If PerlIO claims to have fd we had better be able to fstat() it. */
559             (void) PerlIO_close(fp);
560             goto say_false;
561         }
562 #ifndef PERL_MICRO
563         if (S_ISSOCK(PL_statbuf.st_mode))
564             IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
565 #ifdef HAS_SOCKET
566         else if (
567 #ifdef S_IFMT
568             !(PL_statbuf.st_mode & S_IFMT)
569 #else
570             !PL_statbuf.st_mode
571 #endif
572             && IoTYPE(io) != IoTYPE_WRONLY  /* Dups of STD* filehandles already have */
573             && IoTYPE(io) != IoTYPE_RDONLY  /* type so they aren't marked as sockets */
574         ) {                                 /* on OS's that return 0 on fstat()ed pipe */
575              char tmpbuf[256];
576              Sock_size_t buflen = sizeof tmpbuf;
577              if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
578                       || errno != ENOTSOCK)
579                     IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
580                                                 /* but some return 0 for streams too, sigh */
581         }
582 #endif /* HAS_SOCKET */
583 #endif /* !PERL_MICRO */
584     }
585
586     /* Eeek - FIXME !!!
587      * If this is a standard handle we discard all the layer stuff
588      * and just dup the fd into whatever was on the handle before !
589      */
590
591     if (saveifp) {              /* must use old fp? */
592         /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
593            then dup the new fileno down
594          */
595         if (saveofp) {
596             PerlIO_flush(saveofp);      /* emulate PerlIO_close() */
597             if (saveofp != saveifp) {   /* was a socket? */
598                 PerlIO_close(saveofp);
599             }
600         }
601         if (savefd != fd) {
602             /* Still a small can-of-worms here if (say) PerlIO::scalar
603                is assigned to (say) STDOUT - for now let dup2() fail
604                and provide the error
605              */
606             if (PerlLIO_dup2(fd, savefd) < 0) {
607                 (void)PerlIO_close(fp);
608                 goto say_false;
609             }
610 #ifdef VMS
611             if (savefd != PerlIO_fileno(PerlIO_stdin())) {
612                 char newname[FILENAME_MAX+1];
613                 if (PerlIO_getname(fp, newname)) {
614                     if (fd == PerlIO_fileno(PerlIO_stdout()))
615                         Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
616                     if (fd == PerlIO_fileno(PerlIO_stderr()))
617                         Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",  newname);
618                 }
619             }
620 #endif
621
622 #if !defined(WIN32)
623            /* PL_fdpid isn't used on Windows, so avoid this useless work.
624             * XXX Probably the same for a lot of other places. */
625             {
626                 Pid_t pid;
627                 SV *sv;
628
629                 LOCK_FDPID_MUTEX;
630                 sv = *av_fetch(PL_fdpid,fd,TRUE);
631                 (void)SvUPGRADE(sv, SVt_IV);
632                 pid = SvIVX(sv);
633                 SvIVX(sv) = 0;
634                 sv = *av_fetch(PL_fdpid,savefd,TRUE);
635                 (void)SvUPGRADE(sv, SVt_IV);
636                 SvIVX(sv) = pid;
637                 UNLOCK_FDPID_MUTEX;
638             }
639 #endif
640
641             if (was_fdopen) {
642                 /* need to close fp without closing underlying fd */
643                 int ofd = PerlIO_fileno(fp);
644                 int dupfd = PerlLIO_dup(ofd);
645 #if defined(HAS_FCNTL) && defined(F_SETFD)
646                 /* Assume if we have F_SETFD we have F_GETFD */
647                 int coe = fcntl(ofd,F_GETFD);
648 #endif
649                 PerlIO_close(fp);
650                 PerlLIO_dup2(dupfd,ofd);
651 #if defined(HAS_FCNTL) && defined(F_SETFD)
652                 /* The dup trick has lost close-on-exec on ofd */
653                 fcntl(ofd,F_SETFD, coe);
654 #endif
655                 PerlLIO_close(dupfd);
656             }
657             else
658                 PerlIO_close(fp);
659         }
660         fp = saveifp;
661         PerlIO_clearerr(fp);
662         fd = PerlIO_fileno(fp);
663     }
664 #if defined(HAS_FCNTL) && defined(F_SETFD)
665     if (fd >= 0) {
666         int save_errno = errno;
667         fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
668         errno = save_errno;
669     }
670 #endif
671     IoIFP(io) = fp;
672
673     IoFLAGS(io) &= ~IOf_NOLINE;
674     if (writing) {
675         if (IoTYPE(io) == IoTYPE_SOCKET
676             || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
677             char *s = mode;
678             if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
679               s++;
680             *s = 'w';
681             if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) {
682                 PerlIO_close(fp);
683                 IoIFP(io) = Nullfp;
684                 goto say_false;
685             }
686         }
687         else
688             IoOFP(io) = fp;
689     }
690     return TRUE;
691
692 say_false:
693     IoIFP(io) = saveifp;
694     IoOFP(io) = saveofp;
695     IoTYPE(io) = savetype;
696     return FALSE;
697 }
698
699 PerlIO *
700 Perl_nextargv(pTHX_ register GV *gv)
701 {
702     register SV *sv;
703 #ifndef FLEXFILENAMES
704     int filedev;
705     int fileino;
706 #endif
707     Uid_t fileuid;
708     Gid_t filegid;
709     IO *io = GvIOp(gv);
710
711     if (!PL_argvoutgv)
712         PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
713     if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
714         IoFLAGS(io) &= ~IOf_START;
715         if (PL_inplace) {
716             if (!PL_argvout_stack)
717                 PL_argvout_stack = newAV();
718             av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
719         }
720     }
721     if (PL_filemode & (S_ISUID|S_ISGID)) {
722         PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv)));  /* chmod must follow last write */
723 #ifdef HAS_FCHMOD
724         (void)fchmod(PL_lastfd,PL_filemode);
725 #else
726         (void)PerlLIO_chmod(PL_oldname,PL_filemode);
727 #endif
728     }
729     PL_filemode = 0;
730     if (!GvAV(gv))
731         return Nullfp;
732     while (av_len(GvAV(gv)) >= 0) {
733         STRLEN oldlen;
734         sv = av_shift(GvAV(gv));
735         SAVEFREESV(sv);
736         sv_setsv(GvSV(gv),sv);
737         SvSETMAGIC(GvSV(gv));
738         PL_oldname = SvPVx(GvSV(gv), oldlen);
739         if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
740             if (PL_inplace) {
741                 TAINT_PROPER("inplace open");
742                 if (oldlen == 1 && *PL_oldname == '-') {
743                     setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
744                     return IoIFP(GvIOp(gv));
745                 }
746 #ifndef FLEXFILENAMES
747                 filedev = PL_statbuf.st_dev;
748                 fileino = PL_statbuf.st_ino;
749 #endif
750                 PL_filemode = PL_statbuf.st_mode;
751                 fileuid = PL_statbuf.st_uid;
752                 filegid = PL_statbuf.st_gid;
753                 if (!S_ISREG(PL_filemode)) {
754                     if (ckWARN_d(WARN_INPLACE)) 
755                         Perl_warner(aTHX_ packWARN(WARN_INPLACE),
756                             "Can't do inplace edit: %s is not a regular file",
757                             PL_oldname );
758                     do_close(gv,FALSE);
759                     continue;
760                 }
761                 if (*PL_inplace) {
762                     char *star = strchr(PL_inplace, '*');
763                     if (star) {
764                         char *begin = PL_inplace;
765                         sv_setpvn(sv, "", 0);
766                         do {
767                             sv_catpvn(sv, begin, star - begin);
768                             sv_catpvn(sv, PL_oldname, oldlen);
769                             begin = ++star;
770                         } while ((star = strchr(begin, '*')));
771                         if (*begin)
772                             sv_catpv(sv,begin);
773                     }
774                     else {
775                         sv_catpv(sv,PL_inplace);
776                     }
777 #ifndef FLEXFILENAMES
778                     if ((PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
779                          && PL_statbuf.st_dev == filedev
780                          && PL_statbuf.st_ino == fileino)
781 #ifdef DJGPP
782                         || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
783 #endif
784                       )
785                     {
786                         if (ckWARN_d(WARN_INPLACE))     
787                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
788                               "Can't do inplace edit: %"SVf" would not be unique",
789                               sv);
790                         do_close(gv,FALSE);
791                         continue;
792                     }
793 #endif
794 #ifdef HAS_RENAME
795 #if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC)
796                     if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
797                         if (ckWARN_d(WARN_INPLACE))     
798                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
799                               "Can't rename %s to %"SVf": %s, skipping file",
800                               PL_oldname, sv, Strerror(errno) );
801                         do_close(gv,FALSE);
802                         continue;
803                     }
804 #else
805                     do_close(gv,FALSE);
806                     (void)PerlLIO_unlink(SvPVX(sv));
807                     (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
808                     do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
809 #endif /* DOSISH */
810 #else
811                     (void)UNLINK(SvPVX(sv));
812                     if (link(PL_oldname,SvPVX(sv)) < 0) {
813                         if (ckWARN_d(WARN_INPLACE))     
814                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
815                               "Can't rename %s to %"SVf": %s, skipping file",
816                               PL_oldname, sv, Strerror(errno) );
817                         do_close(gv,FALSE);
818                         continue;
819                     }
820                     (void)UNLINK(PL_oldname);
821 #endif
822                 }
823                 else {
824 #if !defined(DOSISH) && !defined(AMIGAOS)
825 #  ifndef VMS  /* Don't delete; use automatic file versioning */
826                     if (UNLINK(PL_oldname) < 0) {
827                         if (ckWARN_d(WARN_INPLACE))     
828                             Perl_warner(aTHX_ packWARN(WARN_INPLACE),
829                               "Can't remove %s: %s, skipping file",
830                               PL_oldname, Strerror(errno) );
831                         do_close(gv,FALSE);
832                         continue;
833                     }
834 #  endif
835 #else
836                     Perl_croak(aTHX_ "Can't do inplace edit without backup");
837 #endif
838                 }
839
840                 sv_setpvn(sv,">",!PL_inplace);
841                 sv_catpvn(sv,PL_oldname,oldlen);
842                 SETERRNO(0,0);          /* in case sprintf set errno */
843 #ifdef VMS
844                 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
845                  O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
846 #else
847                 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
848                              O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
849 #endif
850                 {
851                     if (ckWARN_d(WARN_INPLACE)) 
852                         Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
853                           PL_oldname, Strerror(errno) );
854                     do_close(gv,FALSE);
855                     continue;
856                 }
857                 setdefout(PL_argvoutgv);
858                 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
859                 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
860 #ifdef HAS_FCHMOD
861                 (void)fchmod(PL_lastfd,PL_filemode);
862 #else
863 #  if !(defined(WIN32) && defined(__BORLANDC__))
864                 /* Borland runtime creates a readonly file! */
865                 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
866 #  endif
867 #endif
868                 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
869 #ifdef HAS_FCHOWN
870                     (void)fchown(PL_lastfd,fileuid,filegid);
871 #else
872 #ifdef HAS_CHOWN
873                     (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
874 #endif
875 #endif
876                 }
877             }
878             return IoIFP(GvIOp(gv));
879         }
880         else {
881             if (ckWARN_d(WARN_INPLACE)) {
882                 int eno = errno;
883                 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
884                     && !S_ISREG(PL_statbuf.st_mode))    
885                 {
886                     Perl_warner(aTHX_ packWARN(WARN_INPLACE),
887                                 "Can't do inplace edit: %s is not a regular file",
888                                 PL_oldname);
889                 }
890                 else
891                     Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
892                                 PL_oldname, Strerror(eno));
893             }
894         }
895     }
896     if (io && (IoFLAGS(io) & IOf_ARGV))
897         IoFLAGS(io) |= IOf_START;
898     if (PL_inplace) {
899         (void)do_close(PL_argvoutgv,FALSE);
900         if (io && (IoFLAGS(io) & IOf_ARGV)
901             && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
902         {
903             GV *oldout = (GV*)av_pop(PL_argvout_stack);
904             setdefout(oldout);
905             SvREFCNT_dec(oldout);
906             return Nullfp;
907         }
908         setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
909     }
910     return Nullfp;
911 }
912
913 #ifdef HAS_PIPE
914 void
915 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
916 {
917     register IO *rstio;
918     register IO *wstio;
919     int fd[2];
920
921     if (!rgv)
922         goto badexit;
923     if (!wgv)
924         goto badexit;
925
926     rstio = GvIOn(rgv);
927     wstio = GvIOn(wgv);
928
929     if (IoIFP(rstio))
930         do_close(rgv,FALSE);
931     if (IoIFP(wstio))
932         do_close(wgv,FALSE);
933
934     if (PerlProc_pipe(fd) < 0)
935         goto badexit;
936     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
937     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE);
938     IoOFP(rstio) = IoIFP(rstio);
939     IoIFP(wstio) = IoOFP(wstio);
940     IoTYPE(rstio) = IoTYPE_RDONLY;
941     IoTYPE(wstio) = IoTYPE_WRONLY;
942     if (!IoIFP(rstio) || !IoOFP(wstio)) {
943         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
944         else PerlLIO_close(fd[0]);
945         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
946         else PerlLIO_close(fd[1]);
947         goto badexit;
948     }
949
950     sv_setsv(sv,&PL_sv_yes);
951     return;
952
953 badexit:
954     sv_setsv(sv,&PL_sv_undef);
955     return;
956 }
957 #endif
958
959 /* explicit renamed to avoid C++ conflict    -- kja */
960 bool
961 Perl_do_close(pTHX_ GV *gv, bool not_implicit)
962 {
963     bool retval;
964     IO *io;
965
966     if (!gv)
967         gv = PL_argvgv;
968     if (!gv || SvTYPE(gv) != SVt_PVGV) {
969         if (not_implicit)
970             SETERRNO(EBADF,SS_IVCHAN);
971         return FALSE;
972     }
973     io = GvIO(gv);
974     if (!io) {          /* never opened */
975         if (not_implicit) {
976             if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
977                 report_evil_fh(gv, io, PL_op->op_type);
978             SETERRNO(EBADF,SS_IVCHAN);
979         }
980         return FALSE;
981     }
982     retval = io_close(io, not_implicit);
983     if (not_implicit) {
984         IoLINES(io) = 0;
985         IoPAGE(io) = 0;
986         IoLINES_LEFT(io) = IoPAGE_LEN(io);
987     }
988     IoTYPE(io) = IoTYPE_CLOSED;
989     return retval;
990 }
991
992 bool
993 Perl_io_close(pTHX_ IO *io, bool not_implicit)
994 {
995     bool retval = FALSE;
996     int status;
997
998     if (IoIFP(io)) {
999         if (IoTYPE(io) == IoTYPE_PIPE) {
1000             status = PerlProc_pclose(IoIFP(io));
1001             if (not_implicit) {
1002                 STATUS_NATIVE_SET(status);
1003                 retval = (STATUS_POSIX == 0);
1004             }
1005             else {
1006                 retval = (status != -1);
1007             }
1008         }
1009         else if (IoTYPE(io) == IoTYPE_STD)
1010             retval = TRUE;
1011         else {
1012             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
1013                 retval = (PerlIO_close(IoOFP(io)) != EOF);
1014                 PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
1015             }
1016             else
1017                 retval = (PerlIO_close(IoIFP(io)) != EOF);
1018         }
1019         IoOFP(io) = IoIFP(io) = Nullfp;
1020     }
1021     else if (not_implicit) {
1022         SETERRNO(EBADF,SS_IVCHAN);
1023     }
1024
1025     return retval;
1026 }
1027
1028 bool
1029 Perl_do_eof(pTHX_ GV *gv)
1030 {
1031     register IO *io;
1032     int ch;
1033
1034     io = GvIO(gv);
1035
1036     if (!io)
1037         return TRUE;
1038     else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY))
1039         report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1040
1041     while (IoIFP(io)) {
1042         int saverrno;
1043
1044         if (PerlIO_has_cntptr(IoIFP(io))) {     /* (the code works without this) */
1045             if (PerlIO_get_cnt(IoIFP(io)) > 0)  /* cheat a little, since */
1046                 return FALSE;                   /* this is the most usual case */
1047         }
1048
1049         saverrno = errno; /* getc and ungetc can stomp on errno */
1050         ch = PerlIO_getc(IoIFP(io));
1051         if (ch != EOF) {
1052             (void)PerlIO_ungetc(IoIFP(io),ch);
1053             errno = saverrno;
1054             return FALSE;
1055         }
1056         errno = saverrno;
1057
1058         if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
1059             if (PerlIO_get_cnt(IoIFP(io)) < -1)
1060                 PerlIO_set_cnt(IoIFP(io),-1);
1061         }
1062         if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
1063             if (gv != PL_argvgv || !nextargv(gv))       /* get another fp handy */
1064                 return TRUE;
1065         }
1066         else
1067             return TRUE;                /* normal fp, definitely end of file */
1068     }
1069     return TRUE;
1070 }
1071
1072 Off_t
1073 Perl_do_tell(pTHX_ GV *gv)
1074 {
1075     register IO *io = 0;
1076     register PerlIO *fp;
1077
1078     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
1079 #ifdef ULTRIX_STDIO_BOTCH
1080         if (PerlIO_eof(fp))
1081             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
1082 #endif
1083         return PerlIO_tell(fp);
1084     }
1085     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1086         report_evil_fh(gv, io, PL_op->op_type);
1087     SETERRNO(EBADF,RMS_IFI);
1088     return (Off_t)-1;
1089 }
1090
1091 bool
1092 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
1093 {
1094     register IO *io = 0;
1095     register PerlIO *fp;
1096
1097     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
1098 #ifdef ULTRIX_STDIO_BOTCH
1099         if (PerlIO_eof(fp))
1100             (void)PerlIO_seek(fp, 0L, 2);       /* ultrix 1.2 workaround */
1101 #endif
1102         return PerlIO_seek(fp, pos, whence) >= 0;
1103     }
1104     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1105         report_evil_fh(gv, io, PL_op->op_type);
1106     SETERRNO(EBADF,RMS_IFI);
1107     return FALSE;
1108 }
1109
1110 Off_t
1111 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
1112 {
1113     register IO *io = 0;
1114     register PerlIO *fp;
1115
1116     if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
1117         return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
1118     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1119         report_evil_fh(gv, io, PL_op->op_type);
1120     SETERRNO(EBADF,RMS_IFI);
1121     return (Off_t)-1;
1122 }
1123
1124 int
1125 Perl_mode_from_discipline(pTHX_ SV *discp)
1126 {
1127     int mode = O_BINARY;
1128     if (discp) {
1129         STRLEN len;
1130         char *s = SvPV(discp,len);
1131         while (*s) {
1132             if (*s == ':') {
1133                 switch (s[1]) {
1134                 case 'r':
1135                     if (len > 3 && strnEQ(s+1, "raw", 3)
1136                         && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1137                     {
1138                         mode = O_BINARY;
1139                         s += 4;
1140                         len -= 4;
1141                         break;
1142                     }
1143                     /* FALL THROUGH */
1144                 case 'c':
1145                     if (len > 4 && strnEQ(s+1, "crlf", 4)
1146                         && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1147                     {
1148                         mode = O_TEXT;
1149                         s += 5;
1150                         len -= 5;
1151                         break;
1152                     }
1153                     /* FALL THROUGH */
1154                 default:
1155                     goto fail_discipline;
1156                 }
1157             }
1158             else if (isSPACE(*s)) {
1159                 ++s;
1160                 --len;
1161             }
1162             else {
1163                 char *end;
1164 fail_discipline:
1165                 end = strchr(s+1, ':');
1166                 if (!end)
1167                     end = s+len;
1168 #ifndef PERLIO_LAYERS
1169                 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
1170 #else
1171                 s = end;
1172 #endif
1173             }
1174         }
1175     }
1176     return mode;
1177 }
1178
1179 int
1180 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
1181 {
1182  /* The old body of this is now in non-LAYER part of perlio.c
1183   * This is a stub for any XS code which might have been calling it.
1184   */
1185  char *name = ":raw";
1186 #ifdef PERLIO_USING_CRLF
1187  if (!(mode & O_BINARY))
1188      name = ":crlf";
1189 #endif
1190  return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
1191 }
1192
1193 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
1194         /* code courtesy of William Kucharski */
1195 #define HAS_CHSIZE
1196
1197 I32 my_chsize(fd, length)
1198 I32 fd;                 /* file descriptor */
1199 Off_t length;           /* length to set file to */
1200 {
1201     struct flock fl;
1202     Stat_t filebuf;
1203
1204     if (PerlLIO_fstat(fd, &filebuf) < 0)
1205         return -1;
1206
1207     if (filebuf.st_size < length) {
1208
1209         /* extend file length */
1210
1211         if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
1212             return -1;
1213
1214         /* write a "0" byte */
1215
1216         if ((PerlLIO_write(fd, "", 1)) != 1)
1217             return -1;
1218     }
1219     else {
1220         /* truncate length */
1221
1222         fl.l_whence = 0;
1223         fl.l_len = 0;
1224         fl.l_start = length;
1225         fl.l_type = F_WRLCK;    /* write lock on file space */
1226
1227         /*
1228         * This relies on the UNDOCUMENTED F_FREESP argument to
1229         * fcntl(2), which truncates the file so that it ends at the
1230         * position indicated by fl.l_start.
1231         *
1232         * Will minor miracles never cease?
1233         */
1234
1235         if (fcntl(fd, F_FREESP, &fl) < 0)
1236             return -1;
1237
1238     }
1239
1240     return 0;
1241 }
1242 #endif /* F_FREESP */
1243
1244 bool
1245 Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
1246 {
1247     register char *tmps;
1248     STRLEN len;
1249
1250     /* assuming fp is checked earlier */
1251     if (!sv)
1252         return TRUE;
1253     if (PL_ofmt) {
1254         if (SvGMAGICAL(sv))
1255             mg_get(sv);
1256         if (SvIOK(sv) && SvIVX(sv) != 0) {
1257             PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
1258             return !PerlIO_error(fp);
1259         }
1260         if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
1261            || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
1262             PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
1263             return !PerlIO_error(fp);
1264         }
1265     }
1266     switch (SvTYPE(sv)) {
1267     case SVt_NULL:
1268         if (ckWARN(WARN_UNINITIALIZED))
1269             report_uninit();
1270         return TRUE;
1271     case SVt_IV:
1272         if (SvIOK(sv)) {
1273             if (SvGMAGICAL(sv))
1274                 mg_get(sv);
1275             if (SvIsUV(sv))
1276                 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1277             else
1278                 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1279             return !PerlIO_error(fp);
1280         }
1281         /* FALL THROUGH */
1282     default:
1283         if (PerlIO_isutf8(fp)) {
1284             if (!SvUTF8(sv))
1285                 sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv),
1286                                       SV_GMAGIC|SV_UTF8_NO_ENCODING);
1287         }
1288         else if (DO_UTF8(sv)) {
1289             if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
1290                 && ckWARN_d(WARN_UTF8))
1291             {
1292                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "Wide character in print");
1293             }
1294         }
1295         tmps = SvPV(sv, len);
1296         break;
1297     }
1298     /* To detect whether the process is about to overstep its
1299      * filesize limit we would need getrlimit().  We could then
1300      * also transparently raise the limit with setrlimit() --
1301      * but only until the system hard limit/the filesystem limit,
1302      * at which we would get EPERM.  Note that when using buffered
1303      * io the write failure can be delayed until the flush/close. --jhi */
1304     if (len && (PerlIO_write(fp,tmps,len) == 0))
1305         return FALSE;
1306     return !PerlIO_error(fp);
1307 }
1308
1309 I32
1310 Perl_my_stat(pTHX)
1311 {
1312     dSP;
1313     IO *io;
1314     GV* gv;
1315
1316     if (PL_op->op_flags & OPf_REF) {
1317         EXTEND(SP,1);
1318         gv = cGVOP_gv;
1319       do_fstat:
1320         io = GvIO(gv);
1321         if (io && IoIFP(io)) {
1322             PL_statgv = gv;
1323             sv_setpv(PL_statname,"");
1324             PL_laststype = OP_STAT;
1325             return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
1326         }
1327         else {
1328             if (gv == PL_defgv)
1329                 return PL_laststatval;
1330             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1331                 report_evil_fh(gv, io, PL_op->op_type);
1332             PL_statgv = Nullgv;
1333             sv_setpv(PL_statname,"");
1334             return (PL_laststatval = -1);
1335         }
1336     }
1337     else {
1338         SV* sv = POPs;
1339         char *s;
1340         STRLEN len;
1341         PUTBACK;
1342         if (SvTYPE(sv) == SVt_PVGV) {
1343             gv = (GV*)sv;
1344             goto do_fstat;
1345         }
1346         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1347             gv = (GV*)SvRV(sv);
1348             goto do_fstat;
1349         }
1350
1351         s = SvPV(sv, len);
1352         PL_statgv = Nullgv;
1353         sv_setpvn(PL_statname, s, len);
1354         s = SvPVX(PL_statname);         /* s now NUL-terminated */
1355         PL_laststype = OP_STAT;
1356         PL_laststatval = PerlLIO_stat(s, &PL_statcache);
1357         if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
1358             Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
1359         return PL_laststatval;
1360     }
1361 }
1362
1363 I32
1364 Perl_my_lstat(pTHX)
1365 {
1366     dSP;
1367     SV *sv;
1368     STRLEN n_a;
1369     if (PL_op->op_flags & OPf_REF) {
1370         EXTEND(SP,1);
1371         if (cGVOP_gv == PL_defgv) {
1372             if (PL_laststype != OP_LSTAT)
1373                 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
1374             return PL_laststatval;
1375         }
1376         if (ckWARN(WARN_IO)) {
1377             Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
1378                     GvENAME(cGVOP_gv));
1379             return (PL_laststatval = -1);
1380         }
1381     }
1382
1383     PL_laststype = OP_LSTAT;
1384     PL_statgv = Nullgv;
1385     sv = POPs;
1386     PUTBACK;
1387     if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) {
1388         Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
1389                 GvENAME((GV*) SvRV(sv)));
1390         return (PL_laststatval = -1);
1391     }
1392     sv_setpv(PL_statname,SvPV(sv, n_a));
1393     PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
1394     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
1395         Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1396     return PL_laststatval;
1397 }
1398
1399 #ifndef OS2
1400 bool
1401 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
1402 {
1403     return do_aexec5(really, mark, sp, 0, 0);
1404 }
1405 #endif
1406
1407 bool
1408 Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1409                int fd, int do_report)
1410 {
1411 #ifdef MACOS_TRADITIONAL
1412     Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1413 #else
1414     register char **a;
1415     char *tmps = Nullch;
1416     STRLEN n_a;
1417
1418     if (sp > mark) {
1419         New(401,PL_Argv, sp - mark + 1, char*);
1420         a = PL_Argv;
1421         while (++mark <= sp) {
1422             if (*mark)
1423                 *a++ = SvPVx(*mark, n_a);
1424             else
1425                 *a++ = "";
1426         }
1427         *a = Nullch;
1428         if (really)
1429             tmps = SvPV(really, n_a);
1430         if ((!really && *PL_Argv[0] != '/') ||
1431             (really && *tmps != '/'))           /* will execvp use PATH? */
1432             TAINT_ENV();                /* testing IFS here is overkill, probably */
1433         PERL_FPU_PRE_EXEC
1434         if (really && *tmps)
1435             PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
1436         else
1437             PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
1438         PERL_FPU_POST_EXEC
1439         if (ckWARN(WARN_EXEC))
1440             Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1441                 (really ? tmps : PL_Argv[0]), Strerror(errno));
1442         if (do_report) {
1443             int e = errno;
1444
1445             PerlLIO_write(fd, (void*)&e, sizeof(int));
1446             PerlLIO_close(fd);
1447         }
1448     }
1449     do_execfree();
1450 #endif
1451     return FALSE;
1452 }
1453
1454 void
1455 Perl_do_execfree(pTHX)
1456 {
1457     if (PL_Argv) {
1458         Safefree(PL_Argv);
1459         PL_Argv = Null(char **);
1460     }
1461     if (PL_Cmd) {
1462         Safefree(PL_Cmd);
1463         PL_Cmd = Nullch;
1464     }
1465 }
1466
1467 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
1468
1469 bool
1470 Perl_do_exec(pTHX_ char *cmd)
1471 {
1472     return do_exec3(cmd,0,0);
1473 }
1474
1475 bool
1476 Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
1477 {
1478     register char **a;
1479     register char *s;
1480
1481     while (*cmd && isSPACE(*cmd))
1482         cmd++;
1483
1484     /* save an extra exec if possible */
1485
1486 #ifdef CSH
1487     {
1488         char flags[10];
1489         if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1490             strnEQ(cmd+PL_cshlen," -c",3)) {
1491           strcpy(flags,"-c");
1492           s = cmd+PL_cshlen+3;
1493           if (*s == 'f') {
1494               s++;
1495               strcat(flags,"f");
1496           }
1497           if (*s == ' ')
1498               s++;
1499           if (*s++ == '\'') {
1500               char *ncmd = s;
1501
1502               while (*s)
1503                   s++;
1504               if (s[-1] == '\n')
1505                   *--s = '\0';
1506               if (s[-1] == '\'') {
1507                   *--s = '\0';
1508                   PERL_FPU_PRE_EXEC
1509                   PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0);
1510                   PERL_FPU_POST_EXEC
1511                   *s = '\'';
1512                   return FALSE;
1513               }
1514           }
1515         }
1516     }
1517 #endif /* CSH */
1518
1519     /* see if there are shell metacharacters in it */
1520
1521     if (*cmd == '.' && isSPACE(cmd[1]))
1522         goto doshell;
1523
1524     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1525         goto doshell;
1526
1527     for (s = cmd; *s && isALNUM(*s); s++) ;     /* catch VAR=val gizmo */
1528     if (*s == '=')
1529         goto doshell;
1530
1531     for (s = cmd; *s; s++) {
1532         if (*s != ' ' && !isALPHA(*s) &&
1533             strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
1534             if (*s == '\n' && !s[1]) {
1535                 *s = '\0';
1536                 break;
1537             }
1538             /* handle the 2>&1 construct at the end */
1539             if (*s == '>' && s[1] == '&' && s[2] == '1'
1540                 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1541                 && (!s[3] || isSPACE(s[3])))
1542             {
1543                 char *t = s + 3;
1544
1545                 while (*t && isSPACE(*t))
1546                     ++t;
1547                 if (!*t && (dup2(1,2) != -1)) {
1548                     s[-2] = '\0';
1549                     break;
1550                 }
1551             }
1552           doshell:
1553             PERL_FPU_PRE_EXEC
1554             PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
1555             PERL_FPU_POST_EXEC
1556             return FALSE;
1557         }
1558     }
1559
1560     New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1561     PL_Cmd = savepvn(cmd, s-cmd);
1562     a = PL_Argv;
1563     for (s = PL_Cmd; *s;) {
1564         while (*s && isSPACE(*s)) s++;
1565         if (*s)
1566             *(a++) = s;
1567         while (*s && !isSPACE(*s)) s++;
1568         if (*s)
1569             *s++ = '\0';
1570     }
1571     *a = Nullch;
1572     if (PL_Argv[0]) {
1573         PERL_FPU_PRE_EXEC
1574         PerlProc_execvp(PL_Argv[0],PL_Argv);
1575         PERL_FPU_POST_EXEC
1576         if (errno == ENOEXEC) {         /* for system V NIH syndrome */
1577             do_execfree();
1578             goto doshell;
1579         }
1580         {
1581             int e = errno;
1582
1583             if (ckWARN(WARN_EXEC))
1584                 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1585                     PL_Argv[0], Strerror(errno));
1586             if (do_report) {
1587                 PerlLIO_write(fd, (void*)&e, sizeof(int));
1588                 PerlLIO_close(fd);
1589             }
1590         }
1591     }
1592     do_execfree();
1593     return FALSE;
1594 }
1595
1596 #endif /* OS2 || WIN32 */
1597
1598 I32
1599 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
1600 {
1601     register I32 val;
1602     register I32 val2;
1603     register I32 tot = 0;
1604     char *what;
1605     char *s;
1606     SV **oldmark = mark;
1607     STRLEN n_a;
1608
1609 #define APPLY_TAINT_PROPER() \
1610     STMT_START {                                                        \
1611         if (PL_tainted) { TAINT_PROPER(what); }                         \
1612     } STMT_END
1613
1614     /* This is a first heuristic; it doesn't catch tainting magic. */
1615     if (PL_tainting) {
1616         while (++mark <= sp) {
1617             if (SvTAINTED(*mark)) {
1618                 TAINT;
1619                 break;
1620             }
1621         }
1622         mark = oldmark;
1623     }
1624     switch (type) {
1625     case OP_CHMOD:
1626         what = "chmod";
1627         APPLY_TAINT_PROPER();
1628         if (++mark <= sp) {
1629             val = SvIVx(*mark);
1630             APPLY_TAINT_PROPER();
1631             tot = sp - mark;
1632             while (++mark <= sp) {
1633                 char *name = SvPVx(*mark, n_a);
1634                 APPLY_TAINT_PROPER();
1635                 if (PerlLIO_chmod(name, val))
1636                     tot--;
1637             }
1638         }
1639         break;
1640 #ifdef HAS_CHOWN
1641     case OP_CHOWN:
1642         what = "chown";
1643         APPLY_TAINT_PROPER();
1644         if (sp - mark > 2) {
1645             val = SvIVx(*++mark);
1646             val2 = SvIVx(*++mark);
1647             APPLY_TAINT_PROPER();
1648             tot = sp - mark;
1649             while (++mark <= sp) {
1650                 char *name = SvPVx(*mark, n_a);
1651                 APPLY_TAINT_PROPER();
1652                 if (PerlLIO_chown(name, val, val2))
1653                     tot--;
1654             }
1655         }
1656         break;
1657 #endif
1658 /*
1659 XXX Should we make lchown() directly available from perl?
1660 For now, we'll let Configure test for HAS_LCHOWN, but do
1661 nothing in the core.
1662     --AD  5/1998
1663 */
1664 #ifdef HAS_KILL
1665     case OP_KILL:
1666         what = "kill";
1667         APPLY_TAINT_PROPER();
1668         if (mark == sp)
1669             break;
1670         s = SvPVx(*++mark, n_a);
1671         if (isALPHA(*s)) {
1672             if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1673                 s += 3;
1674             if ((val = whichsig(s)) < 0)
1675                 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
1676         }
1677         else
1678             val = SvIVx(*mark);
1679         APPLY_TAINT_PROPER();
1680         tot = sp - mark;
1681 #ifdef VMS
1682         /* kill() doesn't do process groups (job trees?) under VMS */
1683         if (val < 0) val = -val;
1684         if (val == SIGKILL) {
1685 #           include <starlet.h>
1686             /* Use native sys$delprc() to insure that target process is
1687              * deleted; supervisor-mode images don't pay attention to
1688              * CRTL's emulation of Unix-style signals and kill()
1689              */
1690             while (++mark <= sp) {
1691                 I32 proc = SvIVx(*mark);
1692                 register unsigned long int __vmssts;
1693                 APPLY_TAINT_PROPER();
1694                 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1695                     tot--;
1696                     switch (__vmssts) {
1697                         case SS$_NONEXPR:
1698                         case SS$_NOSUCHNODE:
1699                             SETERRNO(ESRCH,__vmssts);
1700                             break;
1701                         case SS$_NOPRIV:
1702                             SETERRNO(EPERM,__vmssts);
1703                             break;
1704                         default:
1705                             SETERRNO(EVMSERR,__vmssts);
1706                     }
1707                 }
1708             }
1709             break;
1710         }
1711 #endif
1712         if (val < 0) {
1713             val = -val;
1714             while (++mark <= sp) {
1715                 I32 proc = SvIVx(*mark);
1716                 APPLY_TAINT_PROPER();
1717 #ifdef HAS_KILLPG
1718                 if (PerlProc_killpg(proc,val))  /* BSD */
1719 #else
1720                 if (PerlProc_kill(-proc,val))   /* SYSV */
1721 #endif
1722                     tot--;
1723             }
1724         }
1725         else {
1726             while (++mark <= sp) {
1727                 I32 proc = SvIVx(*mark);
1728                 APPLY_TAINT_PROPER();
1729                 if (PerlProc_kill(proc, val))
1730                     tot--;
1731             }
1732         }
1733         break;
1734 #endif
1735     case OP_UNLINK:
1736         what = "unlink";
1737         APPLY_TAINT_PROPER();
1738         tot = sp - mark;
1739         while (++mark <= sp) {
1740             s = SvPVx(*mark, n_a);
1741             APPLY_TAINT_PROPER();
1742             if (PL_euid || PL_unsafe) {
1743                 if (UNLINK(s))
1744                     tot--;
1745             }
1746             else {      /* don't let root wipe out directories without -U */
1747                 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
1748                     tot--;
1749                 else {
1750                     if (UNLINK(s))
1751                         tot--;
1752                 }
1753             }
1754         }
1755         break;
1756 #ifdef HAS_UTIME
1757     case OP_UTIME:
1758         what = "utime";
1759         APPLY_TAINT_PROPER();
1760         if (sp - mark > 2) {
1761 #if defined(I_UTIME) || defined(VMS)
1762             struct utimbuf utbuf;
1763 #else
1764             struct {
1765                 Time_t  actime;
1766                 Time_t  modtime;
1767             } utbuf;
1768 #endif
1769
1770            SV* accessed = *++mark;
1771            SV* modified = *++mark;
1772            void * utbufp = &utbuf;
1773
1774            /* Be like C, and if both times are undefined, let the C
1775             * library figure out what to do.  This usually means
1776             * "current time". */
1777
1778            if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
1779                 utbufp = NULL;
1780            else {
1781                 Zero(&utbuf, sizeof utbuf, char);
1782 #ifdef BIG_TIME
1783                 utbuf.actime = (Time_t)SvNVx(accessed);  /* time accessed */
1784                 utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */
1785 #else
1786                 utbuf.actime = (Time_t)SvIVx(accessed);  /* time accessed */
1787                 utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */
1788 #endif
1789             }
1790             APPLY_TAINT_PROPER();
1791             tot = sp - mark;
1792             while (++mark <= sp) {
1793                 char *name = SvPVx(*mark, n_a);
1794                 APPLY_TAINT_PROPER();
1795                if (PerlLIO_utime(name, utbufp))
1796                     tot--;
1797             }
1798         }
1799         else
1800             tot = 0;
1801         break;
1802 #endif
1803     }
1804     return tot;
1805
1806 #undef APPLY_TAINT_PROPER
1807 }
1808
1809 /* Do the permissions allow some operation?  Assumes statcache already set. */
1810 #ifndef VMS /* VMS' cando is in vms.c */
1811 bool
1812 Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
1813 /* Note: we use `effective' both for uids and gids.
1814  * Here we are betting on Uid_t being equal or wider than Gid_t.  */
1815 {
1816 #ifdef DOSISH
1817     /* [Comments and code from Len Reed]
1818      * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1819      * to write-protected files.  The execute permission bit is set
1820      * by the Miscrosoft C library stat() function for the following:
1821      *          .exe files
1822      *          .com files
1823      *          .bat files
1824      *          directories
1825      * All files and directories are readable.
1826      * Directories and special files, e.g. "CON", cannot be
1827      * write-protected.
1828      * [Comment by Tom Dinger -- a directory can have the write-protect
1829      *          bit set in the file system, but DOS permits changes to
1830      *          the directory anyway.  In addition, all bets are off
1831      *          here for networked software, such as Novell and
1832      *          Sun's PC-NFS.]
1833      */
1834
1835      /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1836       * too so it will actually look into the files for magic numbers
1837       */
1838      return (mode & statbufp->st_mode) ? TRUE : FALSE;
1839
1840 #else /* ! DOSISH */
1841     if ((effective ? PL_euid : PL_uid) == 0) {  /* root is special */
1842         if (mode == S_IXUSR) {
1843             if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
1844                 return TRUE;
1845         }
1846         else
1847             return TRUE;                /* root reads and writes anything */
1848         return FALSE;
1849     }
1850     if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
1851         if (statbufp->st_mode & mode)
1852             return TRUE;        /* ok as "user" */
1853     }
1854     else if (ingroup(statbufp->st_gid,effective)) {
1855         if (statbufp->st_mode & mode >> 3)
1856             return TRUE;        /* ok as "group" */
1857     }
1858     else if (statbufp->st_mode & mode >> 6)
1859         return TRUE;    /* ok as "other" */
1860     return FALSE;
1861 #endif /* ! DOSISH */
1862 }
1863 #endif /* ! VMS */
1864
1865 bool
1866 Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
1867 {
1868 #ifdef MACOS_TRADITIONAL
1869     /* This is simply not correct for AppleShare, but fix it yerself. */
1870     return TRUE;
1871 #else
1872     if (testgid == (effective ? PL_egid : PL_gid))
1873         return TRUE;
1874 #ifdef HAS_GETGROUPS
1875 #ifndef NGROUPS
1876 #define NGROUPS 32
1877 #endif
1878     {
1879         Groups_t gary[NGROUPS];
1880         I32 anum;
1881
1882         anum = getgroups(NGROUPS,gary);
1883         while (--anum >= 0)
1884             if (gary[anum] == testgid)
1885                 return TRUE;
1886     }
1887 #endif
1888     return FALSE;
1889 #endif
1890 }
1891
1892 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
1893
1894 I32
1895 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
1896 {
1897     key_t key;
1898     I32 n, flags;
1899
1900     key = (key_t)SvNVx(*++mark);
1901     n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1902     flags = SvIVx(*++mark);
1903     SETERRNO(0,0);
1904     switch (optype)
1905     {
1906 #ifdef HAS_MSG
1907     case OP_MSGGET:
1908         return msgget(key, flags);
1909 #endif
1910 #ifdef HAS_SEM
1911     case OP_SEMGET:
1912         return semget(key, n, flags);
1913 #endif
1914 #ifdef HAS_SHM
1915     case OP_SHMGET:
1916         return shmget(key, n, flags);
1917 #endif
1918 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1919     default:
1920         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1921 #endif
1922     }
1923     return -1;                  /* should never happen */
1924 }
1925
1926 I32
1927 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
1928 {
1929     SV *astr;
1930     char *a;
1931     I32 id, n, cmd, infosize, getinfo;
1932     I32 ret = -1;
1933
1934     id = SvIVx(*++mark);
1935     n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1936     cmd = SvIVx(*++mark);
1937     astr = *++mark;
1938     infosize = 0;
1939     getinfo = (cmd == IPC_STAT);
1940
1941     switch (optype)
1942     {
1943 #ifdef HAS_MSG
1944     case OP_MSGCTL:
1945         if (cmd == IPC_STAT || cmd == IPC_SET)
1946             infosize = sizeof(struct msqid_ds);
1947         break;
1948 #endif
1949 #ifdef HAS_SHM
1950     case OP_SHMCTL:
1951         if (cmd == IPC_STAT || cmd == IPC_SET)
1952             infosize = sizeof(struct shmid_ds);
1953         break;
1954 #endif
1955 #ifdef HAS_SEM
1956     case OP_SEMCTL:
1957 #ifdef Semctl
1958         if (cmd == IPC_STAT || cmd == IPC_SET)
1959             infosize = sizeof(struct semid_ds);
1960         else if (cmd == GETALL || cmd == SETALL)
1961         {
1962             struct semid_ds semds;
1963             union semun semun;
1964 #ifdef EXTRA_F_IN_SEMUN_BUF
1965             semun.buff = &semds;
1966 #else
1967             semun.buf = &semds;
1968 #endif
1969             getinfo = (cmd == GETALL);
1970             if (Semctl(id, 0, IPC_STAT, semun) == -1)
1971                 return -1;
1972             infosize = semds.sem_nsems * sizeof(short);
1973                 /* "short" is technically wrong but much more portable
1974                    than guessing about u_?short(_t)? */
1975         }
1976 #else
1977         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1978 #endif
1979         break;
1980 #endif
1981 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
1982     default:
1983         Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
1984 #endif
1985     }
1986
1987     if (infosize)
1988     {
1989         STRLEN len;
1990         if (getinfo)
1991         {
1992             SvPV_force(astr, len);
1993             a = SvGROW(astr, infosize+1);
1994         }
1995         else
1996         {
1997             a = SvPV(astr, len);
1998             if (len != infosize)
1999                 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
2000                       PL_op_desc[optype],
2001                       (unsigned long)len,
2002                       (long)infosize);
2003         }
2004     }
2005     else
2006     {
2007         IV i = SvIV(astr);
2008         a = INT2PTR(char *,i);          /* ouch */
2009     }
2010     SETERRNO(0,0);
2011     switch (optype)
2012     {
2013 #ifdef HAS_MSG
2014     case OP_MSGCTL:
2015         ret = msgctl(id, cmd, (struct msqid_ds *)a);
2016         break;
2017 #endif
2018 #ifdef HAS_SEM
2019     case OP_SEMCTL: {
2020 #ifdef Semctl
2021             union semun unsemds;
2022
2023 #ifdef EXTRA_F_IN_SEMUN_BUF
2024             unsemds.buff = (struct semid_ds *)a;
2025 #else
2026             unsemds.buf = (struct semid_ds *)a;
2027 #endif
2028             ret = Semctl(id, n, cmd, unsemds);
2029 #else
2030             Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
2031 #endif
2032         }
2033         break;
2034 #endif
2035 #ifdef HAS_SHM
2036     case OP_SHMCTL:
2037         ret = shmctl(id, cmd, (struct shmid_ds *)a);
2038         break;
2039 #endif
2040     }
2041     if (getinfo && ret >= 0) {
2042         SvCUR_set(astr, infosize);
2043         *SvEND(astr) = '\0';
2044         SvSETMAGIC(astr);
2045     }
2046     return ret;
2047 }
2048
2049 I32
2050 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
2051 {
2052 #ifdef HAS_MSG
2053     SV *mstr;
2054     char *mbuf;
2055     I32 id, msize, flags;
2056     STRLEN len;
2057
2058     id = SvIVx(*++mark);
2059     mstr = *++mark;
2060     flags = SvIVx(*++mark);
2061     mbuf = SvPV(mstr, len);
2062     if ((msize = len - sizeof(long)) < 0)
2063         Perl_croak(aTHX_ "Arg too short for msgsnd");
2064     SETERRNO(0,0);
2065     return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
2066 #else
2067     Perl_croak(aTHX_ "msgsnd not implemented");
2068 #endif
2069 }
2070
2071 I32
2072 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
2073 {
2074 #ifdef HAS_MSG
2075     SV *mstr;
2076     char *mbuf;
2077     long mtype;
2078     I32 id, msize, flags, ret;
2079     STRLEN len;
2080
2081     id = SvIVx(*++mark);
2082     mstr = *++mark;
2083     /* suppress warning when reading into undef var --jhi */
2084     if (! SvOK(mstr))
2085         sv_setpvn(mstr, "", 0);
2086     msize = SvIVx(*++mark);
2087     mtype = (long)SvIVx(*++mark);
2088     flags = SvIVx(*++mark);
2089     SvPV_force(mstr, len);
2090     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
2091
2092     SETERRNO(0,0);
2093     ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
2094     if (ret >= 0) {
2095         SvCUR_set(mstr, sizeof(long)+ret);
2096         *SvEND(mstr) = '\0';
2097 #ifndef INCOMPLETE_TAINTS
2098         /* who knows who has been playing with this message? */
2099         SvTAINTED_on(mstr);
2100 #endif
2101     }
2102     return ret;
2103 #else
2104     Perl_croak(aTHX_ "msgrcv not implemented");
2105 #endif
2106 }
2107
2108 I32
2109 Perl_do_semop(pTHX_ SV **mark, SV **sp)
2110 {
2111 #ifdef HAS_SEM
2112     SV *opstr;
2113     char *opbuf;
2114     I32 id;
2115     STRLEN opsize;
2116
2117     id = SvIVx(*++mark);
2118     opstr = *++mark;
2119     opbuf = SvPV(opstr, opsize);
2120     if (opsize < 3 * SHORTSIZE
2121         || (opsize % (3 * SHORTSIZE))) {
2122         SETERRNO(EINVAL,LIB_INVARG);
2123         return -1;
2124     }
2125     SETERRNO(0,0);
2126     /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2127     {
2128         int nsops  = opsize / (3 * sizeof (short));
2129         int i      = nsops;
2130         short *ops = (short *) opbuf;
2131         short *o   = ops;
2132         struct sembuf *temps, *t;
2133         I32 result;
2134
2135         New (0, temps, nsops, struct sembuf);
2136         t = temps;
2137         while (i--) {
2138             t->sem_num = *o++;
2139             t->sem_op  = *o++;
2140             t->sem_flg = *o++;
2141             t++;
2142         }
2143         result = semop(id, temps, nsops);
2144         t = temps;
2145         o = ops;
2146         i = nsops;
2147         while (i--) {
2148             *o++ = t->sem_num;
2149             *o++ = t->sem_op;
2150             *o++ = t->sem_flg;
2151             t++;
2152         }
2153         Safefree(temps);
2154         return result;
2155     }
2156 #else
2157     Perl_croak(aTHX_ "semop not implemented");
2158 #endif
2159 }
2160
2161 I32
2162 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
2163 {
2164 #ifdef HAS_SHM
2165     SV *mstr;
2166     char *mbuf, *shm;
2167     I32 id, mpos, msize;
2168     STRLEN len;
2169     struct shmid_ds shmds;
2170
2171     id = SvIVx(*++mark);
2172     mstr = *++mark;
2173     mpos = SvIVx(*++mark);
2174     msize = SvIVx(*++mark);
2175     SETERRNO(0,0);
2176     if (shmctl(id, IPC_STAT, &shmds) == -1)
2177         return -1;
2178     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
2179         SETERRNO(EFAULT,SS_ACCVIO);             /* can't do as caller requested */
2180         return -1;
2181     }
2182     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
2183     if (shm == (char *)-1)      /* I hate System V IPC, I really do */
2184         return -1;
2185     if (optype == OP_SHMREAD) {
2186         /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
2187         if (! SvOK(mstr))
2188             sv_setpvn(mstr, "", 0);
2189         SvPV_force(mstr, len);
2190         mbuf = SvGROW(mstr, msize+1);
2191
2192         Copy(shm + mpos, mbuf, msize, char);
2193         SvCUR_set(mstr, msize);
2194         *SvEND(mstr) = '\0';
2195         SvSETMAGIC(mstr);
2196 #ifndef INCOMPLETE_TAINTS
2197         /* who knows who has been playing with this shared memory? */
2198         SvTAINTED_on(mstr);
2199 #endif
2200     }
2201     else {
2202         I32 n;
2203
2204         mbuf = SvPV(mstr, len);
2205         if ((n = len) > msize)
2206             n = msize;
2207         Copy(mbuf, shm + mpos, n, char);
2208         if (n < msize)
2209             memzero(shm + mpos + n, msize - n);
2210     }
2211     return shmdt(shm);
2212 #else
2213     Perl_croak(aTHX_ "shm I/O not implemented");
2214 #endif
2215 }
2216
2217 #endif /* SYSV IPC */
2218
2219 /*
2220 =head1 IO Functions
2221
2222 =for apidoc start_glob
2223
2224 Function called by C<do_readline> to spawn a glob (or do the glob inside
2225 perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
2226 this glob starter is only used by miniperl during the build process.
2227 Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
2228
2229 =cut
2230 */
2231
2232 PerlIO *
2233 Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2234 {
2235     SV *tmpcmd = NEWSV(55, 0);
2236     PerlIO *fp;
2237     ENTER;
2238     SAVEFREESV(tmpcmd);
2239 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2240            /* since spawning off a process is a real performance hit */
2241     {
2242 #include <descrip.h>
2243 #include <lib$routines.h>
2244 #include <nam.h>
2245 #include <rmsdef.h>
2246         char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
2247         char vmsspec[NAM$C_MAXRSS+1];
2248         char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
2249         $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
2250         PerlIO *tmpfp;
2251         STRLEN i;
2252         struct dsc$descriptor_s wilddsc
2253             = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2254         struct dsc$descriptor_vs rsdsc
2255             = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
2256         unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
2257
2258         /* We could find out if there's an explicit dev/dir or version
2259            by peeking into lib$find_file's internal context at
2260            ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
2261            but that's unsupported, so I don't want to do it now and
2262            have it bite someone in the future. */
2263         cp = SvPV(tmpglob,i);
2264         for (; i; i--) {
2265             if (cp[i] == ';') hasver = 1;
2266             if (cp[i] == '.') {
2267                 if (sts) hasver = 1;
2268                 else sts = 1;
2269             }
2270             if (cp[i] == '/') {
2271                 hasdir = isunix = 1;
2272                 break;
2273             }
2274             if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
2275                 hasdir = 1;
2276                 break;
2277             }
2278         }
2279        if ((tmpfp = PerlIO_tmpfile()) != NULL) {
2280             Stat_t st;
2281             if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
2282                 ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
2283             else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
2284             if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
2285             for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
2286                 if (*cp == '?') *cp = '%';  /* VMS style single-char wildcard */
2287             while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
2288                                                &dfltdsc,NULL,NULL,NULL))&1)) {
2289                 end = rstr + (unsigned long int) *rslt;
2290                 if (!hasver) while (*end != ';') end--;
2291                 *(end++) = '\n';  *end = '\0';
2292                 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
2293                 if (hasdir) {
2294                     if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
2295                     begin = rstr;
2296                 }
2297                 else {
2298                     begin = end;
2299                     while (*(--begin) != ']' && *begin != '>') ;
2300                     ++begin;
2301                 }
2302                 ok = (PerlIO_puts(tmpfp,begin) != EOF);
2303             }
2304             if (cxt) (void)lib$find_file_end(&cxt);
2305             if (ok && sts != RMS$_NMF &&
2306                 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
2307             if (!ok) {
2308                 if (!(sts & 1)) {
2309                     SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
2310                 }
2311                 PerlIO_close(tmpfp);
2312                 fp = NULL;
2313             }
2314             else {
2315                 PerlIO_rewind(tmpfp);
2316                 IoTYPE(io) = IoTYPE_RDONLY;
2317                 IoIFP(io) = fp = tmpfp;
2318                 IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
2319             }
2320         }
2321     }
2322 #else /* !VMS */
2323 #ifdef MACOS_TRADITIONAL
2324     sv_setpv(tmpcmd, "glob ");
2325     sv_catsv(tmpcmd, tmpglob);
2326     sv_catpv(tmpcmd, " |");
2327 #else
2328 #ifdef DOSISH
2329 #ifdef OS2
2330     sv_setpv(tmpcmd, "for a in ");
2331     sv_catsv(tmpcmd, tmpglob);
2332     sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2333 #else
2334 #ifdef DJGPP
2335     sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2336     sv_catsv(tmpcmd, tmpglob);
2337 #else
2338     sv_setpv(tmpcmd, "perlglob ");
2339     sv_catsv(tmpcmd, tmpglob);
2340     sv_catpv(tmpcmd, " |");
2341 #endif /* !DJGPP */
2342 #endif /* !OS2 */
2343 #else /* !DOSISH */
2344 #if defined(CSH)
2345     sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2346     sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2347     sv_catsv(tmpcmd, tmpglob);
2348     sv_catpv(tmpcmd, "' 2>/dev/null |");
2349 #else
2350     sv_setpv(tmpcmd, "echo ");
2351     sv_catsv(tmpcmd, tmpglob);
2352 #if 'z' - 'a' == 25
2353     sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
2354 #else
2355     sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
2356 #endif
2357 #endif /* !CSH */
2358 #endif /* !DOSISH */
2359 #endif /* MACOS_TRADITIONAL */
2360     (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
2361                   FALSE, O_RDONLY, 0, Nullfp);
2362     fp = IoIFP(io);
2363 #endif /* !VMS */
2364     LEAVE;
2365     return fp;
2366 }