This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VOS patches for perl 5.8
[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;
ecdeb87c 603 if (!was_fdopen) {
3500f679 604 PerlIO_close(fp);
ecdeb87c 605 }
6e21c824
LW
606 }
607 fp = saveifp;
760ac839 608 PerlIO_clearerr(fp);
e99cca91 609 fd = PerlIO_fileno(fp);
6e21c824 610 }
a0d0e21e 611#if defined(HAS_FCNTL) && defined(F_SETFD)
e99cca91 612 if (fd >= 0) {
a8710ca1 613 int save_errno = errno;
a8710ca1
GS
614 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
615 errno = save_errno;
616 }
1462b684 617#endif
8990e307 618 IoIFP(io) = fp;
b931b1d9 619
684bef36 620 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 621 if (writing) {
50952442 622 if (IoTYPE(io) == IoTYPE_SOCKET
e99cca91 623 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
b931b1d9 624 mode[0] = 'w';
e99cca91 625 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
760ac839 626 PerlIO_close(fp);
8990e307 627 IoIFP(io) = Nullfp;
6e21c824 628 goto say_false;
fe14fcc3 629 }
1462b684
LW
630 }
631 else
8990e307 632 IoOFP(io) = fp;
bf38876a 633 }
a687059c 634 return TRUE;
6e21c824
LW
635
636say_false:
8990e307
LW
637 IoIFP(io) = saveifp;
638 IoOFP(io) = saveofp;
639 IoTYPE(io) = savetype;
6e21c824 640 return FALSE;
a687059c
LW
641}
642
760ac839 643PerlIO *
864dbfa3 644Perl_nextargv(pTHX_ register GV *gv)
a687059c 645{
79072805 646 register SV *sv;
99b89507 647#ifndef FLEXFILENAMES
c623bd54
LW
648 int filedev;
649 int fileino;
99b89507 650#endif
761237fe
JB
651 Uid_t fileuid;
652 Gid_t filegid;
18708f5a 653 IO *io = GvIOp(gv);
fe14fcc3 654
3280af22
NIS
655 if (!PL_argvoutgv)
656 PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
18708f5a
GS
657 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
658 IoFLAGS(io) &= ~IOf_START;
7a1c5554
GS
659 if (PL_inplace) {
660 if (!PL_argvout_stack)
661 PL_argvout_stack = newAV();
18708f5a 662 av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
7a1c5554 663 }
18708f5a 664 }
3280af22
NIS
665 if (PL_filemode & (S_ISUID|S_ISGID)) {
666 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 667#ifdef HAS_FCHMOD
3280af22 668 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 669#else
b28d0864 670 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
671#endif
672 }
3280af22 673 PL_filemode = 0;
79072805 674 while (av_len(GvAV(gv)) >= 0) {
85aff577 675 STRLEN oldlen;
79072805 676 sv = av_shift(GvAV(gv));
8990e307 677 SAVEFREESV(sv);
79072805
LW
678 sv_setsv(GvSV(gv),sv);
679 SvSETMAGIC(GvSV(gv));
3280af22 680 PL_oldname = SvPVx(GvSV(gv), oldlen);
9d116dd7 681 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
3280af22 682 if (PL_inplace) {
79072805 683 TAINT_PROPER("inplace open");
3280af22 684 if (oldlen == 1 && *PL_oldname == '-') {
4633a7c4 685 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a0d0e21e 686 return IoIFP(GvIOp(gv));
c623bd54 687 }
99b89507 688#ifndef FLEXFILENAMES
b28d0864
NIS
689 filedev = PL_statbuf.st_dev;
690 fileino = PL_statbuf.st_ino;
99b89507 691#endif
3280af22
NIS
692 PL_filemode = PL_statbuf.st_mode;
693 fileuid = PL_statbuf.st_uid;
694 filegid = PL_statbuf.st_gid;
695 if (!S_ISREG(PL_filemode)) {
0453d815
PM
696 if (ckWARN_d(WARN_INPLACE))
697 Perl_warner(aTHX_ WARN_INPLACE,
698 "Can't do inplace edit: %s is not a regular file",
699 PL_oldname );
79072805 700 do_close(gv,FALSE);
c623bd54
LW
701 continue;
702 }
3280af22
NIS
703 if (*PL_inplace) {
704 char *star = strchr(PL_inplace, '*');
2d259d92 705 if (star) {
3280af22 706 char *begin = PL_inplace;
2d259d92
CK
707 sv_setpvn(sv, "", 0);
708 do {
709 sv_catpvn(sv, begin, star - begin);
3280af22 710 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
711 begin = ++star;
712 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
713 if (*begin)
714 sv_catpv(sv,begin);
2d259d92
CK
715 }
716 else {
3280af22 717 sv_catpv(sv,PL_inplace);
2d259d92 718 }
c623bd54 719#ifndef FLEXFILENAMES
5f74f29c
JH
720 if ((PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
721 && PL_statbuf.st_dev == filedev
722 && PL_statbuf.st_ino == fileino)
39e571d4 723#ifdef DJGPP
5f74f29c 724 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 725#endif
f248d071
GS
726 )
727 {
728 if (ckWARN_d(WARN_INPLACE))
729 Perl_warner(aTHX_ WARN_INPLACE,
730 "Can't do inplace edit: %s would not be unique",
731 SvPVX(sv));
79072805 732 do_close(gv,FALSE);
c623bd54
LW
733 continue;
734 }
735#endif
fe14fcc3 736#ifdef HAS_RENAME
d308986b 737#if !defined(DOSISH) && !defined(__CYGWIN__)
3280af22 738 if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
0453d815 739 if (ckWARN_d(WARN_INPLACE))
a1d180c4 740 Perl_warner(aTHX_ WARN_INPLACE,
0453d815
PM
741 "Can't rename %s to %s: %s, skipping file",
742 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 743 do_close(gv,FALSE);
c623bd54
LW
744 continue;
745 }
a687059c 746#else
79072805 747 do_close(gv,FALSE);
3028581b 748 (void)PerlLIO_unlink(SvPVX(sv));
b28d0864 749 (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
9d116dd7 750 do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
55497cff 751#endif /* DOSISH */
ff8e2863 752#else
463ee0b2 753 (void)UNLINK(SvPVX(sv));
b28d0864 754 if (link(PL_oldname,SvPVX(sv)) < 0) {
0453d815
PM
755 if (ckWARN_d(WARN_INPLACE))
756 Perl_warner(aTHX_ WARN_INPLACE,
757 "Can't rename %s to %s: %s, skipping file",
758 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 759 do_close(gv,FALSE);
c623bd54
LW
760 continue;
761 }
b28d0864 762 (void)UNLINK(PL_oldname);
a687059c
LW
763#endif
764 }
765 else {
a8c18271 766#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 767# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 768 if (UNLINK(PL_oldname) < 0) {
0453d815
PM
769 if (ckWARN_d(WARN_INPLACE))
770 Perl_warner(aTHX_ WARN_INPLACE,
771 "Can't remove %s: %s, skipping file",
772 PL_oldname, Strerror(errno) );
79072805 773 do_close(gv,FALSE);
fe14fcc3
LW
774 continue;
775 }
edc7bc49 776# endif
ff8e2863 777#else
cea2e8a9 778 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 779#endif
a687059c
LW
780 }
781
3280af22
NIS
782 sv_setpvn(sv,">",!PL_inplace);
783 sv_catpvn(sv,PL_oldname,oldlen);
748a9306 784 SETERRNO(0,0); /* in case sprintf set errno */
4119ab01
HM
785#ifdef VMS
786 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
18708f5a 787 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
4119ab01 788#else
3280af22 789 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
18708f5a 790 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
4119ab01 791#endif
18708f5a 792 {
0453d815
PM
793 if (ckWARN_d(WARN_INPLACE))
794 Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
795 PL_oldname, Strerror(errno) );
79072805 796 do_close(gv,FALSE);
fe14fcc3
LW
797 continue;
798 }
3280af22
NIS
799 setdefout(PL_argvoutgv);
800 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
801 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 802#ifdef HAS_FCHMOD
3280af22 803 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 804#else
3e3baf6d
TB
805# if !(defined(WIN32) && defined(__BORLANDC__))
806 /* Borland runtime creates a readonly file! */
b28d0864 807 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
3e3baf6d 808# endif
a687059c 809#endif
3280af22 810 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
fe14fcc3 811#ifdef HAS_FCHOWN
3280af22 812 (void)fchown(PL_lastfd,fileuid,filegid);
a687059c 813#else
fe14fcc3 814#ifdef HAS_CHOWN
b28d0864 815 (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
a687059c 816#endif
b1248f16 817#endif
fe14fcc3 818 }
a687059c 819 }
a0d0e21e 820 return IoIFP(GvIOp(gv));
a687059c 821 }
4d61ec05 822 else {
4d61ec05 823 if (ckWARN_d(WARN_INPLACE)) {
6af84f9f
GS
824 int eno = errno;
825 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
826 && !S_ISREG(PL_statbuf.st_mode))
827 {
4d61ec05
GS
828 Perl_warner(aTHX_ WARN_INPLACE,
829 "Can't do inplace edit: %s is not a regular file",
9a7dcd9c 830 PL_oldname);
6af84f9f 831 }
4d61ec05 832 else
9a7dcd9c 833 Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s",
6af84f9f 834 PL_oldname, Strerror(eno));
4d61ec05
GS
835 }
836 }
a687059c 837 }
18708f5a
GS
838 if (io && (IoFLAGS(io) & IOf_ARGV))
839 IoFLAGS(io) |= IOf_START;
3280af22
NIS
840 if (PL_inplace) {
841 (void)do_close(PL_argvoutgv,FALSE);
7a1c5554
GS
842 if (io && (IoFLAGS(io) & IOf_ARGV)
843 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
844 {
18708f5a
GS
845 GV *oldout = (GV*)av_pop(PL_argvout_stack);
846 setdefout(oldout);
847 SvREFCNT_dec(oldout);
848 return Nullfp;
849 }
4633a7c4 850 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a687059c
LW
851 }
852 return Nullfp;
853}
854
fe14fcc3 855#ifdef HAS_PIPE
afd9f252 856void
864dbfa3 857Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
afd9f252 858{
79072805
LW
859 register IO *rstio;
860 register IO *wstio;
afd9f252
LW
861 int fd[2];
862
79072805 863 if (!rgv)
afd9f252 864 goto badexit;
79072805 865 if (!wgv)
afd9f252
LW
866 goto badexit;
867
a0d0e21e
LW
868 rstio = GvIOn(rgv);
869 wstio = GvIOn(wgv);
afd9f252 870
a0d0e21e 871 if (IoIFP(rstio))
79072805 872 do_close(rgv,FALSE);
a0d0e21e 873 if (IoIFP(wstio))
79072805 874 do_close(wgv,FALSE);
afd9f252 875
3028581b 876 if (PerlProc_pipe(fd) < 0)
afd9f252 877 goto badexit;
760ac839
LW
878 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
879 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
8990e307 880 IoIFP(wstio) = IoOFP(wstio);
50952442
JH
881 IoTYPE(rstio) = IoTYPE_RDONLY;
882 IoTYPE(wstio) = IoTYPE_WRONLY;
8990e307 883 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 884 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
3028581b 885 else PerlLIO_close(fd[0]);
760ac839 886 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
3028581b 887 else PerlLIO_close(fd[1]);
fe14fcc3
LW
888 goto badexit;
889 }
afd9f252 890
3280af22 891 sv_setsv(sv,&PL_sv_yes);
afd9f252
LW
892 return;
893
894badexit:
3280af22 895 sv_setsv(sv,&PL_sv_undef);
afd9f252
LW
896 return;
897}
b1248f16 898#endif
afd9f252 899
517844ec 900/* explicit renamed to avoid C++ conflict -- kja */
a687059c 901bool
864dbfa3 902Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 903{
1193dd27
IZ
904 bool retval;
905 IO *io;
a687059c 906
79072805 907 if (!gv)
3280af22 908 gv = PL_argvgv;
a0d0e21e 909 if (!gv || SvTYPE(gv) != SVt_PVGV) {
1d2dff63
GS
910 if (not_implicit)
911 SETERRNO(EBADF,SS$_IVCHAN);
c2ab57d4 912 return FALSE;
99b89507 913 }
79072805
LW
914 io = GvIO(gv);
915 if (!io) { /* never opened */
1d2dff63 916 if (not_implicit) {
2dd78f96
JH
917 if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
918 report_evil_fh(gv, io, PL_op->op_type);
1d2dff63
GS
919 SETERRNO(EBADF,SS$_IVCHAN);
920 }
a687059c
LW
921 return FALSE;
922 }
f2b5be74 923 retval = io_close(io, not_implicit);
517844ec 924 if (not_implicit) {
1193dd27
IZ
925 IoLINES(io) = 0;
926 IoPAGE(io) = 0;
927 IoLINES_LEFT(io) = IoPAGE_LEN(io);
928 }
50952442 929 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ
930 return retval;
931}
932
933bool
f2b5be74 934Perl_io_close(pTHX_ IO *io, bool not_implicit)
1193dd27
IZ
935{
936 bool retval = FALSE;
937 int status;
938
8990e307 939 if (IoIFP(io)) {
50952442 940 if (IoTYPE(io) == IoTYPE_PIPE) {
3028581b 941 status = PerlProc_pclose(IoIFP(io));
f2b5be74
GS
942 if (not_implicit) {
943 STATUS_NATIVE_SET(status);
944 retval = (STATUS_POSIX == 0);
945 }
946 else {
947 retval = (status != -1);
948 }
a687059c 949 }
50952442 950 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW
951 retval = TRUE;
952 else {
8990e307 953 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
760ac839
LW
954 retval = (PerlIO_close(IoOFP(io)) != EOF);
955 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
956 }
957 else
760ac839 958 retval = (PerlIO_close(IoIFP(io)) != EOF);
a687059c 959 }
8990e307 960 IoOFP(io) = IoIFP(io) = Nullfp;
79072805 961 }
f2b5be74 962 else if (not_implicit) {
20408e3c
GS
963 SETERRNO(EBADF,SS$_IVCHAN);
964 }
1193dd27 965
a687059c
LW
966 return retval;
967}
968
969bool
864dbfa3 970Perl_do_eof(pTHX_ GV *gv)
a687059c 971{
79072805 972 register IO *io;
a687059c
LW
973 int ch;
974
79072805 975 io = GvIO(gv);
a687059c 976
79072805 977 if (!io)
a687059c 978 return TRUE;
a00b5bd3 979 else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY))
06bcfee8 980 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
a687059c 981
8990e307 982 while (IoIFP(io)) {
a687059c 983
760ac839 984 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 985 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW
986 return FALSE; /* this is the most usual case */
987 }
a687059c 988
760ac839 989 ch = PerlIO_getc(IoIFP(io));
a687059c 990 if (ch != EOF) {
760ac839 991 (void)PerlIO_ungetc(IoIFP(io),ch);
a687059c
LW
992 return FALSE;
993 }
fab3f3a7 994
760ac839 995 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH
996 if (PerlIO_get_cnt(IoIFP(io)) < -1)
997 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 998 }
533c011a 999 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
ed2c6b9b 1000 if (gv != PL_argvgv || !nextargv(gv)) /* get another fp handy */
a687059c
LW
1001 return TRUE;
1002 }
1003 else
1004 return TRUE; /* normal fp, definitely end of file */
1005 }
1006 return TRUE;
1007}
1008
5ff3f7a4 1009Off_t
864dbfa3 1010Perl_do_tell(pTHX_ GV *gv)
a687059c 1011{
9c5ffd7c 1012 register IO *io = 0;
96e4d5b1 1013 register PerlIO *fp;
a687059c 1014
96e4d5b1 1015 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 1016#ifdef ULTRIX_STDIO_BOTCH
96e4d5b1
PP
1017 if (PerlIO_eof(fp))
1018 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 1019#endif
8903cb82 1020 return PerlIO_tell(fp);
96e4d5b1 1021 }
411caa50
JH
1022 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1023 report_evil_fh(gv, io, PL_op->op_type);
748a9306 1024 SETERRNO(EBADF,RMS$_IFI);
5ff3f7a4 1025 return (Off_t)-1;
a687059c
LW
1026}
1027
1028bool
864dbfa3 1029Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1030{
9c5ffd7c 1031 register IO *io = 0;
137443ea 1032 register PerlIO *fp;
a687059c 1033
137443ea 1034 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 1035#ifdef ULTRIX_STDIO_BOTCH
137443ea
PP
1036 if (PerlIO_eof(fp))
1037 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 1038#endif
8903cb82 1039 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1040 }
411caa50
JH
1041 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1042 report_evil_fh(gv, io, PL_op->op_type);
748a9306 1043 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
1044 return FALSE;
1045}
1046
97cc44eb 1047Off_t
864dbfa3 1048Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1049{
9c5ffd7c 1050 register IO *io = 0;
8903cb82
PP
1051 register PerlIO *fp;
1052
1053 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
3028581b 1054 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
411caa50
JH
1055 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1056 report_evil_fh(gv, io, PL_op->op_type);
8903cb82 1057 SETERRNO(EBADF,RMS$_IFI);
d9b3e12d 1058 return (Off_t)-1;
8903cb82
PP
1059}
1060
6ff81951 1061int
16fe6d59
GS
1062Perl_mode_from_discipline(pTHX_ SV *discp)
1063{
1064 int mode = O_BINARY;
1065 if (discp) {
1066 STRLEN len;
1067 char *s = SvPV(discp,len);
1068 while (*s) {
1069 if (*s == ':') {
1070 switch (s[1]) {
1071 case 'r':
1072 if (len > 3 && strnEQ(s+1, "raw", 3)
1073 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1074 {
1075 mode = O_BINARY;
1076 s += 4;
1077 len -= 4;
1078 break;
1079 }
1080 /* FALL THROUGH */
1081 case 'c':
1082 if (len > 4 && strnEQ(s+1, "crlf", 4)
1083 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1084 {
1085 mode = O_TEXT;
1086 s += 5;
1087 len -= 5;
1088 break;
1089 }
1090 /* FALL THROUGH */
1091 default:
1092 goto fail_discipline;
1093 }
1094 }
1095 else if (isSPACE(*s)) {
1096 ++s;
1097 --len;
1098 }
1099 else {
1100 char *end;
1101fail_discipline:
1102 end = strchr(s+1, ':');
1103 if (!end)
1104 end = s+len;
60382766 1105#ifndef PERLIO_LAYERS
16fe6d59 1106 Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s);
60382766
NIS
1107#else
1108 s = end;
1109#endif
16fe6d59
GS
1110 }
1111 }
1112 }
1113 return mode;
1114}
1115
1116int
1117Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
6ff81951 1118{
60382766
NIS
1119 /* The old body of this is now in non-LAYER part of perlio.c
1120 * This is a stub for any XS code which might have been calling it.
1121 */
6ce75a77 1122 char *name = ":raw";
35990314 1123#ifdef PERLIO_USING_CRLF
8b24e160 1124 if (!(mode & O_BINARY))
6ce75a77
JH
1125 name = ":crlf";
1126#endif
60382766 1127 return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
6ff81951
GS
1128}
1129
a0d0e21e 1130#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
c2ab57d4 1131 /* code courtesy of William Kucharski */
fe14fcc3 1132#define HAS_CHSIZE
6eb13c3b 1133
517844ec 1134I32 my_chsize(fd, length)
79072805 1135I32 fd; /* file descriptor */
85e6fe83 1136Off_t length; /* length to set file to */
6eb13c3b 1137{
6eb13c3b
LW
1138 struct flock fl;
1139 struct stat filebuf;
1140
3028581b 1141 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1142 return -1;
1143
1144 if (filebuf.st_size < length) {
1145
1146 /* extend file length */
1147
3028581b 1148 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1149 return -1;
1150
1151 /* write a "0" byte */
1152
3028581b 1153 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1154 return -1;
1155 }
1156 else {
1157 /* truncate length */
1158
1159 fl.l_whence = 0;
1160 fl.l_len = 0;
1161 fl.l_start = length;
a0d0e21e 1162 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1163
1164 /*
a0d0e21e 1165 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1166 * fcntl(2), which truncates the file so that it ends at the
1167 * position indicated by fl.l_start.
1168 *
1169 * Will minor miracles never cease?
1170 */
1171
a0d0e21e 1172 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1173 return -1;
1174
1175 }
1176
1177 return 0;
1178}
a0d0e21e 1179#endif /* F_FREESP */
ff8e2863 1180
a687059c 1181bool
864dbfa3 1182Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
a687059c
LW
1183{
1184 register char *tmps;
463ee0b2 1185 STRLEN len;
a687059c 1186
79072805
LW
1187 /* assuming fp is checked earlier */
1188 if (!sv)
1189 return TRUE;
3280af22 1190 if (PL_ofmt) {
8990e307 1191 if (SvGMAGICAL(sv))
79072805 1192 mg_get(sv);
463ee0b2 1193 if (SvIOK(sv) && SvIVX(sv) != 0) {
65202027 1194 PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
760ac839 1195 return !PerlIO_error(fp);
79072805 1196 }
463ee0b2 1197 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
79072805 1198 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
3280af22 1199 PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
760ac839 1200 return !PerlIO_error(fp);
79072805 1201 }
a687059c 1202 }
79072805
LW
1203 switch (SvTYPE(sv)) {
1204 case SVt_NULL:
411caa50
JH
1205 if (ckWARN(WARN_UNINITIALIZED))
1206 report_uninit();
ff8e2863 1207 return TRUE;
79072805 1208 case SVt_IV:
a0d0e21e
LW
1209 if (SvIOK(sv)) {
1210 if (SvGMAGICAL(sv))
1211 mg_get(sv);
cf2093f6 1212 if (SvIsUV(sv))
57def98f 1213 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
cf2093f6 1214 else
57def98f 1215 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
760ac839 1216 return !PerlIO_error(fp);
a0d0e21e
LW
1217 }
1218 /* FALL THROUGH */
79072805 1219 default:
7d59b7e4 1220 if (PerlIO_isutf8(fp)) {
f9a63242
JH
1221 if (!SvUTF8(sv))
1222 sv_utf8_upgrade(sv = sv_mortalcopy(sv));
7d59b7e4 1223 }
ae798467 1224 else if (DO_UTF8(sv)) {
2da16753 1225 if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
62961d2e 1226 && ckWARN_d(WARN_UTF8))
2da16753 1227 {
ae798467
NIS
1228 Perl_warner(aTHX_ WARN_UTF8, "Wide character in print");
1229 }
1230 }
f9a63242 1231 tmps = SvPV(sv, len);
79072805 1232 break;
ff8e2863 1233 }
94e4c244
JH
1234 /* To detect whether the process is about to overstep its
1235 * filesize limit we would need getrlimit(). We could then
1236 * also transparently raise the limit with setrlimit() --
1237 * but only until the system hard limit/the filesystem limit,
c5dd3cdd
JH
1238 * at which we would get EPERM. Note that when using buffered
1239 * io the write failure can be delayed until the flush/close. --jhi */
a21ac455 1240 if (len && (PerlIO_write(fp,tmps,len) == 0))
a687059c 1241 return FALSE;
760ac839 1242 return !PerlIO_error(fp);
a687059c
LW
1243}
1244
79072805 1245I32
cea2e8a9 1246Perl_my_stat(pTHX)
a687059c 1247{
39644a26 1248 dSP;
79072805 1249 IO *io;
2dd78f96 1250 GV* gv;
79072805 1251
533c011a 1252 if (PL_op->op_flags & OPf_REF) {
924508f0 1253 EXTEND(SP,1);
2dd78f96 1254 gv = cGVOP_gv;
748a9306 1255 do_fstat:
2dd78f96 1256 io = GvIO(gv);
8990e307 1257 if (io && IoIFP(io)) {
2dd78f96 1258 PL_statgv = gv;
3280af22
NIS
1259 sv_setpv(PL_statname,"");
1260 PL_laststype = OP_STAT;
1261 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
a687059c
LW
1262 }
1263 else {
2dd78f96 1264 if (gv == PL_defgv)
3280af22 1265 return PL_laststatval;
2dd78f96
JH
1266 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1267 report_evil_fh(gv, io, PL_op->op_type);
3280af22
NIS
1268 PL_statgv = Nullgv;
1269 sv_setpv(PL_statname,"");
1270 return (PL_laststatval = -1);
a687059c
LW
1271 }
1272 }
1273 else {
748a9306 1274 SV* sv = POPs;
4b74e3fb 1275 char *s;
2d8e6c8d 1276 STRLEN n_a;
79072805 1277 PUTBACK;
748a9306 1278 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 1279 gv = (GV*)sv;
748a9306
LW
1280 goto do_fstat;
1281 }
1282 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 1283 gv = (GV*)SvRV(sv);
748a9306
LW
1284 goto do_fstat;
1285 }
1286
2d8e6c8d 1287 s = SvPV(sv, n_a);
3280af22
NIS
1288 PL_statgv = Nullgv;
1289 sv_setpv(PL_statname, s);
1290 PL_laststype = OP_STAT;
1291 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
599cee73 1292 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
cea2e8a9 1293 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
3280af22 1294 return PL_laststatval;
a687059c
LW
1295 }
1296}
1297
79072805 1298I32
cea2e8a9 1299Perl_my_lstat(pTHX)
c623bd54 1300{
39644a26 1301 dSP;
79072805 1302 SV *sv;
2d8e6c8d 1303 STRLEN n_a;
533c011a 1304 if (PL_op->op_flags & OPf_REF) {
924508f0 1305 EXTEND(SP,1);
638eceb6 1306 if (cGVOP_gv == PL_defgv) {
3280af22 1307 if (PL_laststype != OP_LSTAT)
cea2e8a9 1308 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
3280af22 1309 return PL_laststatval;
fe14fcc3 1310 }
5d3e98de
RGS
1311 if (ckWARN(WARN_IO)) {
1312 Perl_warner(aTHX_ WARN_IO, "Use of -l on filehandle %s",
1313 GvENAME(cGVOP_gv));
1314 return (PL_laststatval = -1);
1315 }
fe14fcc3 1316 }
c623bd54 1317
3280af22
NIS
1318 PL_laststype = OP_LSTAT;
1319 PL_statgv = Nullgv;
79072805
LW
1320 sv = POPs;
1321 PUTBACK;
5d3e98de
RGS
1322 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) {
1323 Perl_warner(aTHX_ WARN_IO, "Use of -l on filehandle %s",
1324 GvENAME((GV*) SvRV(sv)));
1325 return (PL_laststatval = -1);
1326 }
2d8e6c8d 1327 sv_setpv(PL_statname,SvPV(sv, n_a));
2d8e6c8d 1328 PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
2d8e6c8d 1329 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 1330 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat");
3280af22 1331 return PL_laststatval;
c623bd54
LW
1332}
1333
a687059c 1334bool
864dbfa3 1335Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
a687059c 1336{
d5a9bfb0
IZ
1337 return do_aexec5(really, mark, sp, 0, 0);
1338}
1339
1340bool
2aa1486d
GS
1341Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1342 int fd, int do_report)
d5a9bfb0 1343{
cd39f2b6
JH
1344#ifdef MACOS_TRADITIONAL
1345 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1346#else
a687059c 1347 register char **a;
9c5ffd7c 1348 char *tmps = Nullch;
2d8e6c8d 1349 STRLEN n_a;
a687059c 1350
79072805 1351 if (sp > mark) {
3280af22
NIS
1352 New(401,PL_Argv, sp - mark + 1, char*);
1353 a = PL_Argv;
79072805
LW
1354 while (++mark <= sp) {
1355 if (*mark)
2d8e6c8d 1356 *a++ = SvPVx(*mark, n_a);
a687059c
LW
1357 else
1358 *a++ = "";
1359 }
1360 *a = Nullch;
91b2752f
RG
1361 if (really)
1362 tmps = SvPV(really, n_a);
1363 if ((!really && *PL_Argv[0] != '/') ||
1364 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1365 TAINT_ENV(); /* testing IFS here is overkill, probably */
91b2752f 1366 if (really && *tmps)
b4748376 1367 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
a687059c 1368 else
b4748376 1369 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
599cee73 1370 if (ckWARN(WARN_EXEC))
a1d180c4 1371 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
91b2752f 1372 (really ? tmps : PL_Argv[0]), Strerror(errno));
d5a9bfb0
IZ
1373 if (do_report) {
1374 int e = errno;
1375
1376 PerlLIO_write(fd, (void*)&e, sizeof(int));
1377 PerlLIO_close(fd);
1378 }
a687059c 1379 }
bee1dbe2 1380 do_execfree();
cd39f2b6 1381#endif
a687059c
LW
1382 return FALSE;
1383}
1384
fe14fcc3 1385void
864dbfa3 1386Perl_do_execfree(pTHX)
ff8e2863 1387{
3280af22
NIS
1388 if (PL_Argv) {
1389 Safefree(PL_Argv);
1390 PL_Argv = Null(char **);
ff8e2863 1391 }
3280af22
NIS
1392 if (PL_Cmd) {
1393 Safefree(PL_Cmd);
1394 PL_Cmd = Nullch;
ff8e2863
LW
1395 }
1396}
1397
cd39f2b6 1398#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 1399
a687059c 1400bool
864dbfa3 1401Perl_do_exec(pTHX_ char *cmd)
a687059c 1402{
e446cec8
IZ
1403 return do_exec3(cmd,0,0);
1404}
1405
1406bool
864dbfa3 1407Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
e446cec8 1408{
a687059c
LW
1409 register char **a;
1410 register char *s;
a687059c 1411
748a9306
LW
1412 while (*cmd && isSPACE(*cmd))
1413 cmd++;
1414
a687059c
LW
1415 /* save an extra exec if possible */
1416
bf38876a 1417#ifdef CSH
d05c1ba0
JH
1418 {
1419 char flags[10];
1420 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1421 strnEQ(cmd+PL_cshlen," -c",3)) {
1422 strcpy(flags,"-c");
1423 s = cmd+PL_cshlen+3;
1424 if (*s == 'f') {
1425 s++;
1426 strcat(flags,"f");
1427 }
1428 if (*s == ' ')
1429 s++;
1430 if (*s++ == '\'') {
1431 char *ncmd = s;
1432
1433 while (*s)
1434 s++;
1435 if (s[-1] == '\n')
1436 *--s = '\0';
1437 if (s[-1] == '\'') {
1438 *--s = '\0';
1439 PerlProc_execl(PL_cshname,"csh", flags, ncmd, (char*)0);
1440 *s = '\'';
1441 return FALSE;
1442 }
1443 }
a687059c
LW
1444 }
1445 }
bf38876a 1446#endif /* CSH */
a687059c
LW
1447
1448 /* see if there are shell metacharacters in it */
1449
748a9306
LW
1450 if (*cmd == '.' && isSPACE(cmd[1]))
1451 goto doshell;
1452
1453 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1454 goto doshell;
1455
c170e444 1456 for (s = cmd; *s && isALNUM(*s); s++) ; /* catch VAR=val gizmo */
63f2c1e1
LW
1457 if (*s == '=')
1458 goto doshell;
748a9306 1459
a687059c 1460 for (s = cmd; *s; s++) {
d05c1ba0
JH
1461 if (*s != ' ' && !isALPHA(*s) &&
1462 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1463 if (*s == '\n' && !s[1]) {
1464 *s = '\0';
1465 break;
1466 }
603a98b0
IZ
1467 /* handle the 2>&1 construct at the end */
1468 if (*s == '>' && s[1] == '&' && s[2] == '1'
1469 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1470 && (!s[3] || isSPACE(s[3])))
1471 {
1472 char *t = s + 3;
1473
1474 while (*t && isSPACE(*t))
1475 ++t;
1476 if (!*t && (dup2(1,2) != -1)) {
1477 s[-2] = '\0';
1478 break;
1479 }
1480 }
a687059c 1481 doshell:
3280af22 1482 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
a687059c
LW
1483 return FALSE;
1484 }
1485 }
748a9306 1486
3280af22
NIS
1487 New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1488 PL_Cmd = savepvn(cmd, s-cmd);
1489 a = PL_Argv;
1490 for (s = PL_Cmd; *s;) {
99b89507 1491 while (*s && isSPACE(*s)) s++;
a687059c
LW
1492 if (*s)
1493 *(a++) = s;
99b89507 1494 while (*s && !isSPACE(*s)) s++;
a687059c
LW
1495 if (*s)
1496 *s++ = '\0';
1497 }
1498 *a = Nullch;
3280af22
NIS
1499 if (PL_Argv[0]) {
1500 PerlProc_execvp(PL_Argv[0],PL_Argv);
b1248f16 1501 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1502 do_execfree();
a687059c 1503 goto doshell;
b1248f16 1504 }
d008e5eb 1505 {
e446cec8
IZ
1506 int e = errno;
1507
d008e5eb 1508 if (ckWARN(WARN_EXEC))
a1d180c4 1509 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
d008e5eb 1510 PL_Argv[0], Strerror(errno));
e446cec8
IZ
1511 if (do_report) {
1512 PerlLIO_write(fd, (void*)&e, sizeof(int));
1513 PerlLIO_close(fd);
1514 }
d008e5eb 1515 }
a687059c 1516 }
ff8e2863 1517 do_execfree();
a687059c
LW
1518 return FALSE;
1519}
1520
6890e559 1521#endif /* OS2 || WIN32 */
760ac839 1522
79072805 1523I32
864dbfa3 1524Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
a687059c 1525{
79072805
LW
1526 register I32 val;
1527 register I32 val2;
1528 register I32 tot = 0;
20408e3c 1529 char *what;
a687059c 1530 char *s;
79072805 1531 SV **oldmark = mark;
2d8e6c8d 1532 STRLEN n_a;
a687059c 1533
20408e3c 1534#define APPLY_TAINT_PROPER() \
3280af22 1535 STMT_START { \
17406bd6 1536 if (PL_tainted) { TAINT_PROPER(what); } \
873ef191 1537 } STMT_END
20408e3c
GS
1538
1539 /* This is a first heuristic; it doesn't catch tainting magic. */
3280af22 1540 if (PL_tainting) {
463ee0b2 1541 while (++mark <= sp) {
bbce6d69
PP
1542 if (SvTAINTED(*mark)) {
1543 TAINT;
1544 break;
1545 }
463ee0b2
LW
1546 }
1547 mark = oldmark;
1548 }
a687059c 1549 switch (type) {
79072805 1550 case OP_CHMOD:
20408e3c
GS
1551 what = "chmod";
1552 APPLY_TAINT_PROPER();
79072805 1553 if (++mark <= sp) {
463ee0b2 1554 val = SvIVx(*mark);
20408e3c
GS
1555 APPLY_TAINT_PROPER();
1556 tot = sp - mark;
79072805 1557 while (++mark <= sp) {
2d8e6c8d 1558 char *name = SvPVx(*mark, n_a);
20408e3c
GS
1559 APPLY_TAINT_PROPER();
1560 if (PerlLIO_chmod(name, val))
a687059c
LW
1561 tot--;
1562 }
1563 }
1564 break;
fe14fcc3 1565#ifdef HAS_CHOWN
79072805 1566 case OP_CHOWN:
20408e3c
GS
1567 what = "chown";
1568 APPLY_TAINT_PROPER();
79072805 1569 if (sp - mark > 2) {
463ee0b2
LW
1570 val = SvIVx(*++mark);
1571 val2 = SvIVx(*++mark);
20408e3c 1572 APPLY_TAINT_PROPER();
a0d0e21e 1573 tot = sp - mark;
79072805 1574 while (++mark <= sp) {
2d8e6c8d 1575 char *name = SvPVx(*mark, n_a);
20408e3c 1576 APPLY_TAINT_PROPER();
36660982 1577 if (PerlLIO_chown(name, val, val2))
a687059c
LW
1578 tot--;
1579 }
1580 }
1581 break;
b1248f16 1582#endif
a1d180c4 1583/*
dd64f1c3
AD
1584XXX Should we make lchown() directly available from perl?
1585For now, we'll let Configure test for HAS_LCHOWN, but do
1586nothing in the core.
1587 --AD 5/1998
1588*/
fe14fcc3 1589#ifdef HAS_KILL
79072805 1590 case OP_KILL:
20408e3c
GS
1591 what = "kill";
1592 APPLY_TAINT_PROPER();
55497cff
PP
1593 if (mark == sp)
1594 break;
2d8e6c8d 1595 s = SvPVx(*++mark, n_a);
79072805
LW
1596 if (isUPPER(*s)) {
1597 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1598 s += 3;
1599 if (!(val = whichsig(s)))
cea2e8a9 1600 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
79072805
LW
1601 }
1602 else
463ee0b2 1603 val = SvIVx(*mark);
20408e3c
GS
1604 APPLY_TAINT_PROPER();
1605 tot = sp - mark;
3595fcef
PP
1606#ifdef VMS
1607 /* kill() doesn't do process groups (job trees?) under VMS */
1608 if (val < 0) val = -val;
1609 if (val == SIGKILL) {
1610# include <starlet.h>
1611 /* Use native sys$delprc() to insure that target process is
1612 * deleted; supervisor-mode images don't pay attention to
1613 * CRTL's emulation of Unix-style signals and kill()
1614 */
1615 while (++mark <= sp) {
1616 I32 proc = SvIVx(*mark);
1617 register unsigned long int __vmssts;
20408e3c 1618 APPLY_TAINT_PROPER();
3595fcef
PP
1619 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1620 tot--;
1621 switch (__vmssts) {
1622 case SS$_NONEXPR:
1623 case SS$_NOSUCHNODE:
1624 SETERRNO(ESRCH,__vmssts);
1625 break;
1626 case SS$_NOPRIV:
1627 SETERRNO(EPERM,__vmssts);
1628 break;
1629 default:
1630 SETERRNO(EVMSERR,__vmssts);
1631 }
1632 }
1633 }
1634 break;
1635 }
1636#endif
79072805
LW
1637 if (val < 0) {
1638 val = -val;
1639 while (++mark <= sp) {
463ee0b2 1640 I32 proc = SvIVx(*mark);
20408e3c 1641 APPLY_TAINT_PROPER();
fe14fcc3 1642#ifdef HAS_KILLPG
3028581b 1643 if (PerlProc_killpg(proc,val)) /* BSD */
a687059c 1644#else
3028581b 1645 if (PerlProc_kill(-proc,val)) /* SYSV */
a687059c 1646#endif
79072805 1647 tot--;
a687059c 1648 }
79072805
LW
1649 }
1650 else {
1651 while (++mark <= sp) {
20408e3c
GS
1652 I32 proc = SvIVx(*mark);
1653 APPLY_TAINT_PROPER();
1654 if (PerlProc_kill(proc, val))
79072805 1655 tot--;
a687059c
LW
1656 }
1657 }
1658 break;
b1248f16 1659#endif
79072805 1660 case OP_UNLINK:
20408e3c
GS
1661 what = "unlink";
1662 APPLY_TAINT_PROPER();
79072805
LW
1663 tot = sp - mark;
1664 while (++mark <= sp) {
2d8e6c8d 1665 s = SvPVx(*mark, n_a);
20408e3c 1666 APPLY_TAINT_PROPER();
3280af22 1667 if (PL_euid || PL_unsafe) {
a687059c
LW
1668 if (UNLINK(s))
1669 tot--;
1670 }
1671 else { /* don't let root wipe out directories without -U */
3280af22 1672 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c
LW
1673 tot--;
1674 else {
1675 if (UNLINK(s))
1676 tot--;
1677 }
1678 }
1679 }
1680 break;
a0d0e21e 1681#ifdef HAS_UTIME
79072805 1682 case OP_UTIME:
20408e3c
GS
1683 what = "utime";
1684 APPLY_TAINT_PROPER();
79072805 1685 if (sp - mark > 2) {
748a9306 1686#if defined(I_UTIME) || defined(VMS)
663a0e37
LW
1687 struct utimbuf utbuf;
1688#else
a687059c 1689 struct {
dd2821f6
GS
1690 Time_t actime;
1691 Time_t modtime;
a687059c 1692 } utbuf;
663a0e37 1693#endif
a687059c 1694
c6f7b413
RS
1695 SV* accessed = *++mark;
1696 SV* modified = *++mark;
1697 void * utbufp = &utbuf;
1698
1699 /* be like C, and if both times are undefined, let the C
1700 library figure out what to do. This usually means
1701 "current time" */
1702
1703 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
1704 utbufp = NULL;
06c7082d 1705
afd9f252 1706 Zero(&utbuf, sizeof utbuf, char);
517844ec 1707#ifdef BIG_TIME
c6f7b413
RS
1708 utbuf.actime = (Time_t)SvNVx(accessed); /* time accessed */
1709 utbuf.modtime = (Time_t)SvNVx(modified); /* time modified */
517844ec 1710#else
c6f7b413
RS
1711 utbuf.actime = (Time_t)SvIVx(accessed); /* time accessed */
1712 utbuf.modtime = (Time_t)SvIVx(modified); /* time modified */
517844ec 1713#endif
20408e3c 1714 APPLY_TAINT_PROPER();
79072805
LW
1715 tot = sp - mark;
1716 while (++mark <= sp) {
2d8e6c8d 1717 char *name = SvPVx(*mark, n_a);
20408e3c 1718 APPLY_TAINT_PROPER();
c6f7b413 1719 if (PerlLIO_utime(name, utbufp))
a687059c
LW
1720 tot--;
1721 }
a687059c
LW
1722 }
1723 else
79072805 1724 tot = 0;
a687059c 1725 break;
a0d0e21e 1726#endif
a687059c
LW
1727 }
1728 return tot;
20408e3c 1729
20408e3c 1730#undef APPLY_TAINT_PROPER
a687059c
LW
1731}
1732
1733/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1734#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae
JH
1735bool
1736Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
1737/* Note: we use `effective' both for uids and gids.
1738 * Here we are betting on Uid_t being equal or wider than Gid_t. */
a687059c 1739{
bee1dbe2 1740#ifdef DOSISH
fe14fcc3
LW
1741 /* [Comments and code from Len Reed]
1742 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1743 * to write-protected files. The execute permission bit is set
1744 * by the Miscrosoft C library stat() function for the following:
1745 * .exe files
1746 * .com files
1747 * .bat files
1748 * directories
1749 * All files and directories are readable.
1750 * Directories and special files, e.g. "CON", cannot be
1751 * write-protected.
1752 * [Comment by Tom Dinger -- a directory can have the write-protect
1753 * bit set in the file system, but DOS permits changes to
1754 * the directory anyway. In addition, all bets are off
1755 * here for networked software, such as Novell and
1756 * Sun's PC-NFS.]
1757 */
1758
bee1dbe2
LW
1759 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1760 * too so it will actually look into the files for magic numbers
1761 */
7f4774ae 1762 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 1763
55497cff 1764#else /* ! DOSISH */
3280af22 1765 if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
7f4774ae 1766 if (mode == S_IXUSR) {
c623bd54 1767 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1768 return TRUE;
1769 }
1770 else
1771 return TRUE; /* root reads and writes anything */
1772 return FALSE;
1773 }
3280af22 1774 if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
7f4774ae 1775 if (statbufp->st_mode & mode)
a687059c
LW
1776 return TRUE; /* ok as "user" */
1777 }
d8eceb89 1778 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 1779 if (statbufp->st_mode & mode >> 3)
a687059c
LW
1780 return TRUE; /* ok as "group" */
1781 }
7f4774ae 1782 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
1783 return TRUE; /* ok as "other" */
1784 return FALSE;
55497cff 1785#endif /* ! DOSISH */
a687059c 1786}
a0d0e21e 1787#endif /* ! VMS */
a687059c 1788
d8eceb89
JH
1789bool
1790Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
a687059c 1791{
cd39f2b6
JH
1792#ifdef MACOS_TRADITIONAL
1793 /* This is simply not correct for AppleShare, but fix it yerself. */
1794 return TRUE;
1795#else
3280af22 1796 if (testgid == (effective ? PL_egid : PL_gid))
a687059c 1797 return TRUE;
fe14fcc3 1798#ifdef HAS_GETGROUPS
a687059c
LW
1799#ifndef NGROUPS
1800#define NGROUPS 32
1801#endif
1802 {
a0d0e21e 1803 Groups_t gary[NGROUPS];
79072805 1804 I32 anum;
a687059c
LW
1805
1806 anum = getgroups(NGROUPS,gary);
1807 while (--anum >= 0)
1808 if (gary[anum] == testgid)
1809 return TRUE;
1810 }
1811#endif
1812 return FALSE;
cd39f2b6 1813#endif
a687059c 1814}
c2ab57d4 1815
fe14fcc3 1816#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1817
79072805 1818I32
864dbfa3 1819Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1820{
c2ab57d4 1821 key_t key;
79072805 1822 I32 n, flags;
c2ab57d4 1823
463ee0b2
LW
1824 key = (key_t)SvNVx(*++mark);
1825 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1826 flags = SvIVx(*++mark);
748a9306 1827 SETERRNO(0,0);
c2ab57d4
LW
1828 switch (optype)
1829 {
fe14fcc3 1830#ifdef HAS_MSG
79072805 1831 case OP_MSGGET:
c2ab57d4 1832 return msgget(key, flags);
e5d73d77 1833#endif
fe14fcc3 1834#ifdef HAS_SEM
79072805 1835 case OP_SEMGET:
c2ab57d4 1836 return semget(key, n, flags);
e5d73d77 1837#endif
fe14fcc3 1838#ifdef HAS_SHM
79072805 1839 case OP_SHMGET:
c2ab57d4 1840 return shmget(key, n, flags);
e5d73d77 1841#endif
fe14fcc3 1842#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1843 default:
cea2e8a9 1844 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 1845#endif
c2ab57d4
LW
1846 }
1847 return -1; /* should never happen */
1848}
1849
79072805 1850I32
864dbfa3 1851Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1852{
79072805 1853 SV *astr;
c2ab57d4 1854 char *a;
a0d0e21e
LW
1855 I32 id, n, cmd, infosize, getinfo;
1856 I32 ret = -1;
c2ab57d4 1857
463ee0b2
LW
1858 id = SvIVx(*++mark);
1859 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1860 cmd = SvIVx(*++mark);
79072805 1861 astr = *++mark;
c2ab57d4
LW
1862 infosize = 0;
1863 getinfo = (cmd == IPC_STAT);
1864
1865 switch (optype)
1866 {
fe14fcc3 1867#ifdef HAS_MSG
79072805 1868 case OP_MSGCTL:
c2ab57d4
LW
1869 if (cmd == IPC_STAT || cmd == IPC_SET)
1870 infosize = sizeof(struct msqid_ds);
1871 break;
e5d73d77 1872#endif
fe14fcc3 1873#ifdef HAS_SHM
79072805 1874 case OP_SHMCTL:
c2ab57d4
LW
1875 if (cmd == IPC_STAT || cmd == IPC_SET)
1876 infosize = sizeof(struct shmid_ds);
1877 break;
e5d73d77 1878#endif
fe14fcc3 1879#ifdef HAS_SEM
79072805 1880 case OP_SEMCTL:
39398f3f 1881#ifdef Semctl
c2ab57d4
LW
1882 if (cmd == IPC_STAT || cmd == IPC_SET)
1883 infosize = sizeof(struct semid_ds);
1884 else if (cmd == GETALL || cmd == SETALL)
1885 {
8e591e46 1886 struct semid_ds semds;
bd89102f 1887 union semun semun;
e6f0bdd6
GS
1888#ifdef EXTRA_F_IN_SEMUN_BUF
1889 semun.buff = &semds;
1890#else
84902520 1891 semun.buf = &semds;
e6f0bdd6 1892#endif
c2ab57d4 1893 getinfo = (cmd == GETALL);
9b89d93d
GB
1894 if (Semctl(id, 0, IPC_STAT, semun) == -1)
1895 return -1;
6e21c824
LW
1896 infosize = semds.sem_nsems * sizeof(short);
1897 /* "short" is technically wrong but much more portable
1898 than guessing about u_?short(_t)? */
c2ab57d4 1899 }
39398f3f 1900#else
cea2e8a9 1901 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 1902#endif
c2ab57d4 1903 break;
e5d73d77 1904#endif
fe14fcc3 1905#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1906 default:
cea2e8a9 1907 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 1908#endif
c2ab57d4
LW
1909 }
1910
1911 if (infosize)
1912 {
a0d0e21e 1913 STRLEN len;
c2ab57d4
LW
1914 if (getinfo)
1915 {
a0d0e21e
LW
1916 SvPV_force(astr, len);
1917 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
1918 }
1919 else
1920 {
463ee0b2
LW
1921 a = SvPV(astr, len);
1922 if (len != infosize)
cea2e8a9 1923 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
1924 PL_op_desc[optype],
1925 (unsigned long)len,
1926 (long)infosize);
c2ab57d4
LW
1927 }
1928 }
1929 else
1930 {
c030ccd9 1931 IV i = SvIV(astr);
56431972 1932 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 1933 }
748a9306 1934 SETERRNO(0,0);
c2ab57d4
LW
1935 switch (optype)
1936 {
fe14fcc3 1937#ifdef HAS_MSG
79072805 1938 case OP_MSGCTL:
bee1dbe2 1939 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 1940 break;
e5d73d77 1941#endif
fe14fcc3 1942#ifdef HAS_SEM
bd89102f 1943 case OP_SEMCTL: {
39398f3f 1944#ifdef Semctl
bd89102f
AD
1945 union semun unsemds;
1946
e6f0bdd6
GS
1947#ifdef EXTRA_F_IN_SEMUN_BUF
1948 unsemds.buff = (struct semid_ds *)a;
1949#else
bd89102f 1950 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 1951#endif
bd89102f 1952 ret = Semctl(id, n, cmd, unsemds);
39398f3f 1953#else
cea2e8a9 1954 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 1955#endif
bd89102f 1956 }
c2ab57d4 1957 break;
e5d73d77 1958#endif
fe14fcc3 1959#ifdef HAS_SHM
79072805 1960 case OP_SHMCTL:
bee1dbe2 1961 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 1962 break;
e5d73d77 1963#endif
c2ab57d4
LW
1964 }
1965 if (getinfo && ret >= 0) {
79072805
LW
1966 SvCUR_set(astr, infosize);
1967 *SvEND(astr) = '\0';
a0d0e21e 1968 SvSETMAGIC(astr);
c2ab57d4
LW
1969 }
1970 return ret;
1971}
1972
79072805 1973I32
864dbfa3 1974Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 1975{
fe14fcc3 1976#ifdef HAS_MSG
79072805 1977 SV *mstr;
c2ab57d4 1978 char *mbuf;
79072805 1979 I32 id, msize, flags;
463ee0b2 1980 STRLEN len;
c2ab57d4 1981
463ee0b2 1982 id = SvIVx(*++mark);
79072805 1983 mstr = *++mark;
463ee0b2
LW
1984 flags = SvIVx(*++mark);
1985 mbuf = SvPV(mstr, len);
1986 if ((msize = len - sizeof(long)) < 0)
cea2e8a9 1987 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 1988 SETERRNO(0,0);
bee1dbe2 1989 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 1990#else
cea2e8a9 1991 Perl_croak(aTHX_ "msgsnd not implemented");
e5d73d77 1992#endif
c2ab57d4
LW
1993}
1994
79072805 1995I32
864dbfa3 1996Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 1997{
fe14fcc3 1998#ifdef HAS_MSG
79072805 1999 SV *mstr;
c2ab57d4
LW
2000 char *mbuf;
2001 long mtype;
79072805 2002 I32 id, msize, flags, ret;
463ee0b2 2003 STRLEN len;
79072805 2004
463ee0b2 2005 id = SvIVx(*++mark);
79072805 2006 mstr = *++mark;
c2e66d9e
GS
2007 /* suppress warning when reading into undef var --jhi */
2008 if (! SvOK(mstr))
2009 sv_setpvn(mstr, "", 0);
463ee0b2
LW
2010 msize = SvIVx(*++mark);
2011 mtype = (long)SvIVx(*++mark);
2012 flags = SvIVx(*++mark);
a0d0e21e
LW
2013 SvPV_force(mstr, len);
2014 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2015
748a9306 2016 SETERRNO(0,0);
bee1dbe2 2017 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 2018 if (ret >= 0) {
79072805
LW
2019 SvCUR_set(mstr, sizeof(long)+ret);
2020 *SvEND(mstr) = '\0';
41d6edb2
JH
2021#ifndef INCOMPLETE_TAINTS
2022 /* who knows who has been playing with this message? */
2023 SvTAINTED_on(mstr);
2024#endif
c2ab57d4
LW
2025 }
2026 return ret;
e5d73d77 2027#else
cea2e8a9 2028 Perl_croak(aTHX_ "msgrcv not implemented");
e5d73d77 2029#endif
c2ab57d4
LW
2030}
2031
79072805 2032I32
864dbfa3 2033Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2034{
fe14fcc3 2035#ifdef HAS_SEM
79072805 2036 SV *opstr;
c2ab57d4 2037 char *opbuf;
463ee0b2
LW
2038 I32 id;
2039 STRLEN opsize;
c2ab57d4 2040
463ee0b2 2041 id = SvIVx(*++mark);
79072805 2042 opstr = *++mark;
463ee0b2 2043 opbuf = SvPV(opstr, opsize);
248ff010
NC
2044 if (opsize < 3 * SHORTSIZE
2045 || (opsize % (3 * SHORTSIZE))) {
748a9306 2046 SETERRNO(EINVAL,LIB$_INVARG);
c2ab57d4
LW
2047 return -1;
2048 }
748a9306 2049 SETERRNO(0,0);
248ff010
NC
2050 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2051 {
2052 int nsops = opsize / (3 * sizeof (short));
2053 int i = nsops;
2054 short *ops = (short *) opbuf;
2055 short *o = ops;
2056 struct sembuf *temps, *t;
2057 I32 result;
2058
2059 New (0, temps, nsops, struct sembuf);
2060 t = temps;
2061 while (i--) {
2062 t->sem_num = *o++;
2063 t->sem_op = *o++;
2064 t->sem_flg = *o++;
2065 t++;
2066 }
2067 result = semop(id, temps, nsops);
2068 t = temps;
2069 o = ops;
2070 i = nsops;
2071 while (i--) {
2072 *o++ = t->sem_num;
2073 *o++ = t->sem_op;
2074 *o++ = t->sem_flg;
2075 t++;
2076 }
2077 Safefree(temps);
2078 return result;
2079 }
e5d73d77 2080#else
cea2e8a9 2081 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2082#endif
c2ab57d4
LW
2083}
2084
79072805 2085I32
864dbfa3 2086Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2087{
fe14fcc3 2088#ifdef HAS_SHM
79072805 2089 SV *mstr;
c2ab57d4 2090 char *mbuf, *shm;
79072805 2091 I32 id, mpos, msize;
463ee0b2 2092 STRLEN len;
c2ab57d4 2093 struct shmid_ds shmds;
c2ab57d4 2094
463ee0b2 2095 id = SvIVx(*++mark);
79072805 2096 mstr = *++mark;
463ee0b2
LW
2097 mpos = SvIVx(*++mark);
2098 msize = SvIVx(*++mark);
748a9306 2099 SETERRNO(0,0);
c2ab57d4
LW
2100 if (shmctl(id, IPC_STAT, &shmds) == -1)
2101 return -1;
2102 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
748a9306 2103 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2104 return -1;
2105 }
8ac85365 2106 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2107 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2108 return -1;
79072805 2109 if (optype == OP_SHMREAD) {
9f538c04
GS
2110 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
2111 if (! SvOK(mstr))
2112 sv_setpvn(mstr, "", 0);
a0d0e21e
LW
2113 SvPV_force(mstr, len);
2114 mbuf = SvGROW(mstr, msize+1);
2115
bee1dbe2 2116 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2117 SvCUR_set(mstr, msize);
2118 *SvEND(mstr) = '\0';
a0d0e21e 2119 SvSETMAGIC(mstr);
d929ce6f
JH
2120#ifndef INCOMPLETE_TAINTS
2121 /* who knows who has been playing with this shared memory? */
2122 SvTAINTED_on(mstr);
2123#endif
c2ab57d4
LW
2124 }
2125 else {
79072805 2126 I32 n;
c2ab57d4 2127
a0d0e21e 2128 mbuf = SvPV(mstr, len);
463ee0b2 2129 if ((n = len) > msize)
c2ab57d4 2130 n = msize;
bee1dbe2 2131 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2132 if (n < msize)
bee1dbe2 2133 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2134 }
2135 return shmdt(shm);
e5d73d77 2136#else
cea2e8a9 2137 Perl_croak(aTHX_ "shm I/O not implemented");
e5d73d77 2138#endif
c2ab57d4
LW
2139}
2140
fe14fcc3 2141#endif /* SYSV IPC */
4e35701f 2142
0d44d22b 2143/*
ccfc67b7
JH
2144=head1 IO Functions
2145
0d44d22b
NC
2146=for apidoc start_glob
2147
2148Function called by C<do_readline> to spawn a glob (or do the glob inside
2149perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2150this glob starter is only used by miniperl during the build process.
0d44d22b 2151Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
fab3f3a7 2152
0d44d22b
NC
2153=cut
2154*/
2155
2156PerlIO *
2157Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2158{
2159 SV *tmpcmd = NEWSV(55, 0);
2160 PerlIO *fp;
2161 ENTER;
2162 SAVEFREESV(tmpcmd);
2163#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2164 /* since spawning off a process is a real performance hit */
2165 {
2166#include <descrip.h>
2167#include <lib$routines.h>
2168#include <nam.h>
2169#include <rmsdef.h>
2170 char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
2171 char vmsspec[NAM$C_MAXRSS+1];
2172 char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
0d44d22b
NC
2173 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
2174 PerlIO *tmpfp;
2175 STRLEN i;
2176 struct dsc$descriptor_s wilddsc
2177 = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2178 struct dsc$descriptor_vs rsdsc
2179 = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
2180 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
2181
2182 /* We could find out if there's an explicit dev/dir or version
2183 by peeking into lib$find_file's internal context at
2184 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
2185 but that's unsupported, so I don't want to do it now and
2186 have it bite someone in the future. */
0d44d22b
NC
2187 cp = SvPV(tmpglob,i);
2188 for (; i; i--) {
2189 if (cp[i] == ';') hasver = 1;
2190 if (cp[i] == '.') {
2191 if (sts) hasver = 1;
2192 else sts = 1;
2193 }
2194 if (cp[i] == '/') {
2195 hasdir = isunix = 1;
2196 break;
2197 }
2198 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
2199 hasdir = 1;
2200 break;
2201 }
2202 }
a15cef0c 2203 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
0d44d22b
NC
2204 Stat_t st;
2205 if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
2206 ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
2207 else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
2208 if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
a3987cb8
JH
2209 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
2210 if (*cp == '?') *cp = '%'; /* VMS style single-char wildcard */
0d44d22b
NC
2211 while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
2212 &dfltdsc,NULL,NULL,NULL))&1)) {
2213 end = rstr + (unsigned long int) *rslt;
2214 if (!hasver) while (*end != ';') end--;
2215 *(end++) = '\n'; *end = '\0';
2216 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
2217 if (hasdir) {
2218 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
2219 begin = rstr;
2220 }
2221 else {
2222 begin = end;
2223 while (*(--begin) != ']' && *begin != '>') ;
2224 ++begin;
2225 }
2226 ok = (PerlIO_puts(tmpfp,begin) != EOF);
2227 }
2228 if (cxt) (void)lib$find_file_end(&cxt);
2229 if (ok && sts != RMS$_NMF &&
2230 sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
2231 if (!ok) {
2232 if (!(sts & 1)) {
2233 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
2234 }
2235 PerlIO_close(tmpfp);
2236 fp = NULL;
2237 }
2238 else {
2239 PerlIO_rewind(tmpfp);
2240 IoTYPE(io) = IoTYPE_RDONLY;
2241 IoIFP(io) = fp = tmpfp;
2242 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
2243 }
2244 }
2245 }
2246#else /* !VMS */
2247#ifdef MACOS_TRADITIONAL
2248 sv_setpv(tmpcmd, "glob ");
2249 sv_catsv(tmpcmd, tmpglob);
2250 sv_catpv(tmpcmd, " |");
2251#else
2252#ifdef DOSISH
2253#ifdef OS2
2254 sv_setpv(tmpcmd, "for a in ");
2255 sv_catsv(tmpcmd, tmpglob);
2256 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2257#else
2258#ifdef DJGPP
2259 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2260 sv_catsv(tmpcmd, tmpglob);
2261#else
2262 sv_setpv(tmpcmd, "perlglob ");
2263 sv_catsv(tmpcmd, tmpglob);
2264 sv_catpv(tmpcmd, " |");
2265#endif /* !DJGPP */
2266#endif /* !OS2 */
2267#else /* !DOSISH */
2268#if defined(CSH)
2269 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2270 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2271 sv_catsv(tmpcmd, tmpglob);
2272 sv_catpv(tmpcmd, "' 2>/dev/null |");
2273#else
2274 sv_setpv(tmpcmd, "echo ");
2275 sv_catsv(tmpcmd, tmpglob);
2276#if 'z' - 'a' == 25
2277 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
2278#else
2279 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
2280#endif
2281#endif /* !CSH */
2282#endif /* !DOSISH */
2283#endif /* MACOS_TRADITIONAL */
2284 (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
2285 FALSE, O_RDONLY, 0, Nullfp);
2286 fp = IoIFP(io);
2287#endif /* !VMS */
2288 LEAVE;
2289 return fp;
2290}