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