This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VMS patches
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
9607fc9c 3 * Copyright (c) 1991-1997, 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"
18#include "perl.h"
19
fe14fcc3 20#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 21#include <sys/ipc.h>
fe14fcc3 22#ifdef HAS_MSG
c2ab57d4 23#include <sys/msg.h>
e5d73d77 24#endif
fe14fcc3 25#ifdef HAS_SEM
c2ab57d4 26#include <sys/sem.h>
e5d73d77 27#endif
fe14fcc3 28#ifdef HAS_SHM
c2ab57d4 29#include <sys/shm.h>
a0d0e21e
LW
30# ifndef HAS_SHMAT_PROTOTYPE
31 extern Shmat_t shmat _((int, char *, int));
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
ff8e2863
LW
44#ifdef I_FCNTL
45#include <fcntl.h>
46#endif
fe14fcc3
LW
47#ifdef I_SYS_FILE
48#include <sys/file.h>
49#endif
85aff577
CS
50#ifdef O_EXCL
51# define OPEN_EXCL O_EXCL
52#else
53# define OPEN_EXCL 0
54#endif
a687059c 55
76121258
PP
56#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
57#include <signal.h>
58#endif
59
60/* XXX If this causes problems, set i_unistd=undef in the hint file. */
61#ifdef I_UNISTD
62# include <unistd.h>
63#endif
64
232e078e
AD
65#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
66# include <sys/socket.h>
67# include <netdb.h>
68# ifndef ENOTSOCK
69# ifdef I_NET_ERRNO
70# include <net/errno.h>
71# endif
72# endif
73#endif
74
d574b85e
CS
75/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
76#ifndef Sock_size_t
137443ea 77# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS
78# define Sock_size_t Size_t
79# else
80# define Sock_size_t int
81# endif
82#endif
83
a687059c 84bool
6acef3b7 85do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
a687059c 86{
a0d0e21e 87 register IO *io = GvIOn(gv);
760ac839
LW
88 PerlIO *saveifp = Nullfp;
89 PerlIO *saveofp = Nullfp;
6e21c824 90 char savetype = ' ';
c07a80fd 91 int writing = 0;
760ac839 92 PerlIO *fp;
c07a80fd
PP
93 int fd;
94 int result;
3500f679 95 bool was_fdopen = FALSE;
a687059c 96
3280af22 97 PL_forkprocess = 1; /* assume true if no fork */
c07a80fd 98
a0d0e21e 99 if (IoIFP(io)) {
760ac839 100 fd = PerlIO_fileno(IoIFP(io));
8990e307 101 if (IoTYPE(io) == '-')
c2ab57d4 102 result = 0;
3280af22 103 else if (fd <= PL_maxsysfd) {
8990e307
LW
104 saveifp = IoIFP(io);
105 saveofp = IoOFP(io);
106 savetype = IoTYPE(io);
6e21c824
LW
107 result = 0;
108 }
8990e307 109 else if (IoTYPE(io) == '|')
3028581b 110 result = PerlProc_pclose(IoIFP(io));
8990e307
LW
111 else if (IoIFP(io) != IoOFP(io)) {
112 if (IoOFP(io)) {
760ac839
LW
113 result = PerlIO_close(IoOFP(io));
114 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
115 }
116 else
760ac839 117 result = PerlIO_close(IoIFP(io));
a687059c 118 }
a687059c 119 else
760ac839 120 result = PerlIO_close(IoIFP(io));
3280af22 121 if (result == EOF && fd > PL_maxsysfd)
760ac839 122 PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
79072805 123 GvENAME(gv));
8990e307 124 IoOFP(io) = IoIFP(io) = Nullfp;
a687059c 125 }
c07a80fd
PP
126
127 if (as_raw) {
128 result = rawmode & 3;
129 IoTYPE(io) = "<>++"[result];
130 writing = (result > 0);
3028581b 131 fd = PerlLIO_open3(name, rawmode, rawperm);
c07a80fd
PP
132 if (fd == -1)
133 fp = NULL;
134 else {
360e5741
CS
135 char *fpmode;
136 if (result == 0)
137 fpmode = "r";
138#ifdef O_APPEND
139 else if (rawmode & O_APPEND)
140 fpmode = (result == 1) ? "a" : "a+";
141#endif
142 else
143 fpmode = (result == 1) ? "w" : "r+";
144 fp = PerlIO_fdopen(fd, fpmode);
c07a80fd 145 if (!fp)
3028581b 146 PerlLIO_close(fd);
c07a80fd 147 }
a687059c 148 }
c07a80fd
PP
149 else {
150 char *myname;
151 char mode[3]; /* stdio file mode ("r\0" or "r+\0") */
152 int dodup;
153
154 myname = savepvn(name, len);
155 SAVEFREEPV(myname);
156 name = myname;
157 while (len && isSPACE(name[len-1]))
158 name[--len] = '\0';
159
160 mode[0] = mode[1] = mode[2] = '\0';
161 IoTYPE(io) = *name;
162 if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
163 mode[1] = *name++;
164 --len;
165 writing = 1;
a687059c 166 }
c07a80fd
PP
167
168 if (*name == '|') {
169 /*SUPPRESS 530*/
170 for (name++; isSPACE(*name); name++) ;
171 if (strNE(name,"-"))
172 TAINT_ENV();
173 TAINT_PROPER("piped open");
7b8d334a
GS
174 if (name[strlen(name)-1] == '|') {
175 name[strlen(name)-1] = '\0' ;
3280af22 176 if (PL_dowarn)
7b8d334a
GS
177 warn("Can't do bidirectional pipe");
178 }
3028581b 179 fp = PerlProc_popen(name,"w");
c07a80fd
PP
180 writing = 1;
181 }
182 else if (*name == '>') {
183 TAINT_PROPER("open");
bf38876a 184 name++;
c07a80fd
PP
185 if (*name == '>') {
186 mode[0] = IoTYPE(io) = 'a';
bf38876a 187 name++;
a0d0e21e 188 }
c07a80fd
PP
189 else
190 mode[0] = 'w';
191 writing = 1;
192
193 if (*name == '&') {
194 duplicity:
195 dodup = 1;
196 name++;
197 if (*name == '=') {
198 dodup = 0;
a0d0e21e 199 name++;
c07a80fd
PP
200 }
201 if (!*name && supplied_fp)
202 fp = supplied_fp;
a0d0e21e 203 else {
c07a80fd
PP
204 /*SUPPRESS 530*/
205 for (; isSPACE(*name); name++) ;
206 if (isDIGIT(*name))
207 fd = atoi(name);
208 else {
209 IO* thatio;
210 gv = gv_fetchpv(name,FALSE,SVt_PVIO);
211 thatio = GvIO(gv);
212 if (!thatio) {
6e21c824 213#ifdef EINVAL
c07a80fd 214 SETERRNO(EINVAL,SS$_IVCHAN);
6e21c824 215#endif
c07a80fd
PP
216 goto say_false;
217 }
218 if (IoIFP(thatio)) {
760ac839 219 fd = PerlIO_fileno(IoIFP(thatio));
c07a80fd
PP
220 if (IoTYPE(thatio) == 's')
221 IoTYPE(io) = 's';
222 }
223 else
224 fd = -1;
a0d0e21e 225 }
fec02dd3 226 if (dodup)
3028581b 227 fd = PerlLIO_dup(fd);
3500f679
RS
228 else
229 was_fdopen = TRUE;
760ac839 230 if (!(fp = PerlIO_fdopen(fd,mode))) {
c07a80fd 231 if (dodup)
3028581b 232 PerlLIO_close(fd);
517844ec 233 }
c07a80fd 234 }
bf38876a 235 }
c07a80fd
PP
236 else {
237 /*SUPPRESS 530*/
238 for (; isSPACE(*name); name++) ;
239 if (strEQ(name,"-")) {
760ac839 240 fp = PerlIO_stdout();
c07a80fd
PP
241 IoTYPE(io) = '-';
242 }
243 else {
760ac839 244 fp = PerlIO_open(name,mode);
c07a80fd 245 }
bf38876a
LW
246 }
247 }
c07a80fd
PP
248 else if (*name == '<') {
249 /*SUPPRESS 530*/
250 for (name++; isSPACE(*name); name++) ;
bf38876a 251 mode[0] = 'r';
bf38876a
LW
252 if (*name == '&')
253 goto duplicity;
a687059c 254 if (strEQ(name,"-")) {
760ac839 255 fp = PerlIO_stdin();
8990e307 256 IoTYPE(io) = '-';
a687059c 257 }
bf38876a 258 else
760ac839 259 fp = PerlIO_open(name,mode);
a687059c 260 }
00db4c45 261 else if (len > 1 && name[len-1] == '|') {
a687059c 262 name[--len] = '\0';
99b89507 263 while (len && isSPACE(name[len-1]))
a687059c 264 name[--len] = '\0';
99b89507
LW
265 /*SUPPRESS 530*/
266 for (; isSPACE(*name); name++) ;
79072805
LW
267 if (strNE(name,"-"))
268 TAINT_ENV();
269 TAINT_PROPER("piped open");
3028581b 270 fp = PerlProc_popen(name,"r");
8990e307 271 IoTYPE(io) = '|';
a687059c
LW
272 }
273 else {
8990e307 274 IoTYPE(io) = '<';
99b89507
LW
275 /*SUPPRESS 530*/
276 for (; isSPACE(*name); name++) ;
a687059c 277 if (strEQ(name,"-")) {
760ac839 278 fp = PerlIO_stdin();
8990e307 279 IoTYPE(io) = '-';
a687059c
LW
280 }
281 else
760ac839 282 fp = PerlIO_open(name,"r");
a687059c
LW
283 }
284 }
bee1dbe2 285 if (!fp) {
3280af22 286 if (PL_dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
bee1dbe2 287 warn(warn_nl, "open");
6e21c824 288 goto say_false;
bee1dbe2 289 }
8990e307
LW
290 if (IoTYPE(io) &&
291 IoTYPE(io) != '|' && IoTYPE(io) != '-') {
96827780 292 dTHR;
3280af22 293 if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
760ac839 294 (void)PerlIO_close(fp);
6e21c824 295 goto say_false;
a687059c 296 }
3280af22 297 if (S_ISSOCK(PL_statbuf.st_mode))
8990e307 298 IoTYPE(io) = 's'; /* in case a socket was passed in to us */
99b89507
LW
299#ifdef HAS_SOCKET
300 else if (
c623bd54 301#ifdef S_IFMT
3280af22 302 !(PL_statbuf.st_mode & S_IFMT)
99b89507 303#else
b28d0864 304 !PL_statbuf.st_mode
99b89507
LW
305#endif
306 ) {
96827780
MB
307 char tmpbuf[256];
308 Sock_size_t buflen = sizeof tmpbuf;
3028581b 309 if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
d574b85e
CS
310 &buflen) >= 0
311 || errno != ENOTSOCK)
8990e307 312 IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
99b89507
LW
313 /* but some return 0 for streams too, sigh */
314 }
bf38876a 315#endif
a687059c 316 }
6e21c824 317 if (saveifp) { /* must use old fp? */
760ac839 318 fd = PerlIO_fileno(saveifp);
6e21c824 319 if (saveofp) {
760ac839 320 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
6e21c824 321 if (saveofp != saveifp) { /* was a socket? */
760ac839 322 PerlIO_close(saveofp);
99b89507
LW
323 if (fd > 2)
324 Safefree(saveofp);
6e21c824
LW
325 }
326 }
760ac839 327 if (fd != PerlIO_fileno(fp)) {
bee1dbe2 328 int pid;
79072805 329 SV *sv;
bee1dbe2 330
3028581b 331 PerlLIO_dup2(PerlIO_fileno(fp), fd);
3280af22 332 sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
a0d0e21e 333 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2
LW
334 pid = SvIVX(sv);
335 SvIVX(sv) = 0;
3280af22 336 sv = *av_fetch(PL_fdpid,fd,TRUE);
a0d0e21e 337 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2 338 SvIVX(sv) = pid;
3500f679
RS
339 if (!was_fdopen)
340 PerlIO_close(fp);
bee1dbe2 341
6e21c824
LW
342 }
343 fp = saveifp;
760ac839 344 PerlIO_clearerr(fp);
6e21c824 345 }
a0d0e21e 346#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 347 fd = PerlIO_fileno(fp);
3280af22 348 fcntl(fd,F_SETFD,fd > PL_maxsysfd);
1462b684 349#endif
8990e307 350 IoIFP(io) = fp;
bf38876a 351 if (writing) {
96827780 352 dTHR;
8990e307 353 if (IoTYPE(io) == 's'
3280af22 354 || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) {
760ac839
LW
355 if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
356 PerlIO_close(fp);
8990e307 357 IoIFP(io) = Nullfp;
6e21c824 358 goto say_false;
fe14fcc3 359 }
1462b684
LW
360 }
361 else
8990e307 362 IoOFP(io) = fp;
bf38876a 363 }
a687059c 364 return TRUE;
6e21c824
LW
365
366say_false:
8990e307
LW
367 IoIFP(io) = saveifp;
368 IoOFP(io) = saveofp;
369 IoTYPE(io) = savetype;
6e21c824 370 return FALSE;
a687059c
LW
371}
372
760ac839 373PerlIO *
8ac85365 374nextargv(register GV *gv)
a687059c 375{
79072805 376 register SV *sv;
99b89507 377#ifndef FLEXFILENAMES
c623bd54
LW
378 int filedev;
379 int fileino;
99b89507 380#endif
c623bd54
LW
381 int fileuid;
382 int filegid;
fe14fcc3 383
3280af22
NIS
384 if (!PL_argvoutgv)
385 PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
386 if (PL_filemode & (S_ISUID|S_ISGID)) {
387 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 388#ifdef HAS_FCHMOD
3280af22 389 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 390#else
b28d0864 391 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
392#endif
393 }
3280af22 394 PL_filemode = 0;
79072805 395 while (av_len(GvAV(gv)) >= 0) {
11343788 396 dTHR;
85aff577 397 STRLEN oldlen;
79072805 398 sv = av_shift(GvAV(gv));
8990e307 399 SAVEFREESV(sv);
79072805
LW
400 sv_setsv(GvSV(gv),sv);
401 SvSETMAGIC(GvSV(gv));
3280af22
NIS
402 PL_oldname = SvPVx(GvSV(gv), oldlen);
403 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,0,0,Nullfp)) {
404 if (PL_inplace) {
79072805 405 TAINT_PROPER("inplace open");
3280af22 406 if (oldlen == 1 && *PL_oldname == '-') {
4633a7c4 407 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a0d0e21e 408 return IoIFP(GvIOp(gv));
c623bd54 409 }
99b89507 410#ifndef FLEXFILENAMES
b28d0864
NIS
411 filedev = PL_statbuf.st_dev;
412 fileino = PL_statbuf.st_ino;
99b89507 413#endif
3280af22
NIS
414 PL_filemode = PL_statbuf.st_mode;
415 fileuid = PL_statbuf.st_uid;
416 filegid = PL_statbuf.st_gid;
417 if (!S_ISREG(PL_filemode)) {
c623bd54 418 warn("Can't do inplace edit: %s is not a regular file",
3280af22 419 PL_oldname );
79072805 420 do_close(gv,FALSE);
c623bd54
LW
421 continue;
422 }
3280af22
NIS
423 if (*PL_inplace) {
424 char *star = strchr(PL_inplace, '*');
2d259d92 425 if (star) {
3280af22 426 char *begin = PL_inplace;
2d259d92
CK
427 sv_setpvn(sv, "", 0);
428 do {
429 sv_catpvn(sv, begin, star - begin);
3280af22 430 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
431 begin = ++star;
432 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
433 if (*begin)
434 sv_catpv(sv,begin);
2d259d92
CK
435 }
436 else {
3280af22 437 sv_catpv(sv,PL_inplace);
2d259d92 438 }
c623bd54 439#ifndef FLEXFILENAMES
b28d0864
NIS
440 if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
441 && PL_statbuf.st_dev == filedev
442 && PL_statbuf.st_ino == fileino
39e571d4
ML
443#ifdef DJGPP
444 || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
445#endif
446 ) {
447 warn("Can't do inplace edit: %s would not be uniq",
463ee0b2 448 SvPVX(sv) );
79072805 449 do_close(gv,FALSE);
c623bd54
LW
450 continue;
451 }
452#endif
fe14fcc3 453#ifdef HAS_RENAME
bee1dbe2 454#ifndef DOSISH
3280af22 455 if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
c623bd54 456 warn("Can't rename %s to %s: %s, skipping file",
3280af22 457 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 458 do_close(gv,FALSE);
c623bd54
LW
459 continue;
460 }
a687059c 461#else
79072805 462 do_close(gv,FALSE);
3028581b 463 (void)PerlLIO_unlink(SvPVX(sv));
b28d0864
NIS
464 (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
465 do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,0,0,Nullfp);
55497cff 466#endif /* DOSISH */
ff8e2863 467#else
463ee0b2 468 (void)UNLINK(SvPVX(sv));
b28d0864 469 if (link(PL_oldname,SvPVX(sv)) < 0) {
c623bd54 470 warn("Can't rename %s to %s: %s, skipping file",
b28d0864 471 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 472 do_close(gv,FALSE);
c623bd54
LW
473 continue;
474 }
b28d0864 475 (void)UNLINK(PL_oldname);
a687059c
LW
476#endif
477 }
478 else {
a8c18271 479#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 480# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 481 if (UNLINK(PL_oldname) < 0) {
85aff577 482 warn("Can't remove %s: %s, skipping file",
3280af22 483 PL_oldname, Strerror(errno) );
79072805 484 do_close(gv,FALSE);
fe14fcc3
LW
485 continue;
486 }
edc7bc49 487# endif
ff8e2863 488#else
463ee0b2 489 croak("Can't do inplace edit without backup");
ff8e2863 490#endif
a687059c
LW
491 }
492
3280af22
NIS
493 sv_setpvn(sv,">",!PL_inplace);
494 sv_catpvn(sv,PL_oldname,oldlen);
748a9306 495 SETERRNO(0,0); /* in case sprintf set errno */
4119ab01
HM
496#ifdef VMS
497 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
498 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) {
499#else
3280af22 500 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
85aff577 501 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
4119ab01 502#endif
c623bd54 503 warn("Can't do inplace edit on %s: %s",
3280af22 504 PL_oldname, Strerror(errno) );
79072805 505 do_close(gv,FALSE);
fe14fcc3
LW
506 continue;
507 }
3280af22
NIS
508 setdefout(PL_argvoutgv);
509 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
510 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 511#ifdef HAS_FCHMOD
3280af22 512 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 513#else
3e3baf6d
TB
514# if !(defined(WIN32) && defined(__BORLANDC__))
515 /* Borland runtime creates a readonly file! */
b28d0864 516 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
3e3baf6d 517# endif
a687059c 518#endif
3280af22 519 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
fe14fcc3 520#ifdef HAS_FCHOWN
3280af22 521 (void)fchown(PL_lastfd,fileuid,filegid);
a687059c 522#else
fe14fcc3 523#ifdef HAS_CHOWN
b28d0864 524 (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
a687059c 525#endif
b1248f16 526#endif
fe14fcc3 527 }
a687059c 528 }
a0d0e21e 529 return IoIFP(GvIOp(gv));
a687059c
LW
530 }
531 else
22fae026 532 PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
3280af22 533 SvPV(sv, PL_na), Strerror(errno));
a687059c 534 }
3280af22
NIS
535 if (PL_inplace) {
536 (void)do_close(PL_argvoutgv,FALSE);
4633a7c4 537 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a687059c
LW
538 }
539 return Nullfp;
540}
541
fe14fcc3 542#ifdef HAS_PIPE
afd9f252 543void
8ac85365 544do_pipe(SV *sv, GV *rgv, GV *wgv)
afd9f252 545{
79072805
LW
546 register IO *rstio;
547 register IO *wstio;
afd9f252
LW
548 int fd[2];
549
79072805 550 if (!rgv)
afd9f252 551 goto badexit;
79072805 552 if (!wgv)
afd9f252
LW
553 goto badexit;
554
a0d0e21e
LW
555 rstio = GvIOn(rgv);
556 wstio = GvIOn(wgv);
afd9f252 557
a0d0e21e 558 if (IoIFP(rstio))
79072805 559 do_close(rgv,FALSE);
a0d0e21e 560 if (IoIFP(wstio))
79072805 561 do_close(wgv,FALSE);
afd9f252 562
3028581b 563 if (PerlProc_pipe(fd) < 0)
afd9f252 564 goto badexit;
760ac839
LW
565 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
566 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
8990e307
LW
567 IoIFP(wstio) = IoOFP(wstio);
568 IoTYPE(rstio) = '<';
569 IoTYPE(wstio) = '>';
570 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 571 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
3028581b 572 else PerlLIO_close(fd[0]);
760ac839 573 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
3028581b 574 else PerlLIO_close(fd[1]);
fe14fcc3
LW
575 goto badexit;
576 }
afd9f252 577
3280af22 578 sv_setsv(sv,&PL_sv_yes);
afd9f252
LW
579 return;
580
581badexit:
3280af22 582 sv_setsv(sv,&PL_sv_undef);
afd9f252
LW
583 return;
584}
b1248f16 585#endif
afd9f252 586
517844ec 587/* explicit renamed to avoid C++ conflict -- kja */
a687059c 588bool
517844ec 589do_close(GV *gv, bool not_implicit)
a687059c 590{
1193dd27
IZ
591 bool retval;
592 IO *io;
a687059c 593
79072805 594 if (!gv)
3280af22 595 gv = PL_argvgv;
a0d0e21e 596 if (!gv || SvTYPE(gv) != SVt_PVGV) {
1d2dff63
GS
597 if (not_implicit)
598 SETERRNO(EBADF,SS$_IVCHAN);
c2ab57d4 599 return FALSE;
99b89507 600 }
79072805
LW
601 io = GvIO(gv);
602 if (!io) { /* never opened */
1d2dff63 603 if (not_implicit) {
3280af22 604 if (PL_dowarn)
1d2dff63
GS
605 warn("Close on unopened file <%s>",GvENAME(gv));
606 SETERRNO(EBADF,SS$_IVCHAN);
607 }
a687059c
LW
608 return FALSE;
609 }
1193dd27 610 retval = io_close(io);
517844ec 611 if (not_implicit) {
1193dd27
IZ
612 IoLINES(io) = 0;
613 IoPAGE(io) = 0;
614 IoLINES_LEFT(io) = IoPAGE_LEN(io);
615 }
616 IoTYPE(io) = ' ';
617 return retval;
618}
619
620bool
8ac85365 621io_close(IO *io)
1193dd27
IZ
622{
623 bool retval = FALSE;
624 int status;
625
8990e307
LW
626 if (IoIFP(io)) {
627 if (IoTYPE(io) == '|') {
3028581b 628 status = PerlProc_pclose(IoIFP(io));
f86702cc 629 STATUS_NATIVE_SET(status);
1e422769 630 retval = (STATUS_POSIX == 0);
a687059c 631 }
8990e307 632 else if (IoTYPE(io) == '-')
a687059c
LW
633 retval = TRUE;
634 else {
8990e307 635 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
760ac839
LW
636 retval = (PerlIO_close(IoOFP(io)) != EOF);
637 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
638 }
639 else
760ac839 640 retval = (PerlIO_close(IoIFP(io)) != EOF);
a687059c 641 }
8990e307 642 IoOFP(io) = IoIFP(io) = Nullfp;
79072805 643 }
20408e3c
GS
644 else {
645 SETERRNO(EBADF,SS$_IVCHAN);
646 }
1193dd27 647
a687059c
LW
648 return retval;
649}
650
651bool
8ac85365 652do_eof(GV *gv)
a687059c 653{
11343788 654 dTHR;
79072805 655 register IO *io;
a687059c
LW
656 int ch;
657
79072805 658 io = GvIO(gv);
a687059c 659
79072805 660 if (!io)
a687059c
LW
661 return TRUE;
662
8990e307 663 while (IoIFP(io)) {
a687059c 664
760ac839
LW
665 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
666 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
667 return FALSE; /* this is the most usual case */
668 }
a687059c 669
760ac839 670 ch = PerlIO_getc(IoIFP(io));
a687059c 671 if (ch != EOF) {
760ac839 672 (void)PerlIO_ungetc(IoIFP(io),ch);
a687059c
LW
673 return FALSE;
674 }
760ac839
LW
675 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
676 if (PerlIO_get_cnt(IoIFP(io)) < -1)
677 PerlIO_set_cnt(IoIFP(io),-1);
678 }
533c011a 679 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
3280af22 680 if (!nextargv(PL_argvgv)) /* get another fp handy */
a687059c
LW
681 return TRUE;
682 }
683 else
684 return TRUE; /* normal fp, definitely end of file */
685 }
686 return TRUE;
687}
688
689long
8ac85365 690do_tell(GV *gv)
a687059c 691{
79072805 692 register IO *io;
96e4d5b1 693 register PerlIO *fp;
a687059c 694
96e4d5b1 695 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 696#ifdef ULTRIX_STDIO_BOTCH
96e4d5b1
PP
697 if (PerlIO_eof(fp))
698 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 699#endif
8903cb82 700 return PerlIO_tell(fp);
96e4d5b1 701 }
3280af22 702 if (PL_dowarn)
8903cb82 703 warn("tell() on unopened file");
748a9306 704 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
705 return -1L;
706}
707
708bool
8ac85365 709do_seek(GV *gv, long int pos, int whence)
a687059c 710{
79072805 711 register IO *io;
137443ea 712 register PerlIO *fp;
a687059c 713
137443ea 714 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 715#ifdef ULTRIX_STDIO_BOTCH
137443ea
PP
716 if (PerlIO_eof(fp))
717 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 718#endif
8903cb82 719 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 720 }
3280af22 721 if (PL_dowarn)
8903cb82 722 warn("seek() on unopened file");
748a9306 723 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
724 return FALSE;
725}
726
8903cb82 727long
8ac85365 728do_sysseek(GV *gv, long int pos, int whence)
8903cb82
PP
729{
730 register IO *io;
731 register PerlIO *fp;
732
733 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
3028581b 734 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
3280af22 735 if (PL_dowarn)
8903cb82
PP
736 warn("sysseek() on unopened file");
737 SETERRNO(EBADF,RMS$_IFI);
738 return -1L;
739}
740
6ff81951
GS
741int
742do_binmode(PerlIO *fp, int iotype, int flag)
743{
744 if (flag != TRUE)
745 croak("panic: unsetting binmode"); /* Not implemented yet */
746#ifdef DOSISH
747#ifdef atarist
748 if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
749 return 1;
750 else
751 return 0;
752#else
753 if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
754#if defined(WIN32) && defined(__BORLANDC__)
755 /* The translation mode of the stream is maintained independent
756 * of the translation mode of the fd in the Borland RTL (heavy
757 * digging through their runtime sources reveal). User has to
758 * set the mode explicitly for the stream (though they don't
759 * document this anywhere). GSAR 97-5-24
760 */
761 PerlIO_seek(fp,0L,0);
873ef191 762 ((FILE*)fp)->flags |= _F_BIN;
6ff81951
GS
763#endif
764 return 1;
765 }
766 else
767 return 0;
768#endif
769#else
770#if defined(USEMYBINMODE)
771 if (my_binmode(fp,iotype) != NULL)
772 return 1;
773 else
774 return 0;
775#else
776 return 1;
777#endif
778#endif
779}
780
a0d0e21e 781#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
c2ab57d4 782 /* code courtesy of William Kucharski */
fe14fcc3 783#define HAS_CHSIZE
6eb13c3b 784
517844ec 785I32 my_chsize(fd, length)
79072805 786I32 fd; /* file descriptor */
85e6fe83 787Off_t length; /* length to set file to */
6eb13c3b 788{
6eb13c3b
LW
789 struct flock fl;
790 struct stat filebuf;
791
3028581b 792 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
793 return -1;
794
795 if (filebuf.st_size < length) {
796
797 /* extend file length */
798
3028581b 799 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
800 return -1;
801
802 /* write a "0" byte */
803
3028581b 804 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
805 return -1;
806 }
807 else {
808 /* truncate length */
809
810 fl.l_whence = 0;
811 fl.l_len = 0;
812 fl.l_start = length;
a0d0e21e 813 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
814
815 /*
a0d0e21e 816 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
817 * fcntl(2), which truncates the file so that it ends at the
818 * position indicated by fl.l_start.
819 *
820 * Will minor miracles never cease?
821 */
822
a0d0e21e 823 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
824 return -1;
825
826 }
827
828 return 0;
829}
a0d0e21e 830#endif /* F_FREESP */
ff8e2863 831
a687059c 832bool
6acef3b7 833do_print(register SV *sv, PerlIO *fp)
a687059c
LW
834{
835 register char *tmps;
463ee0b2 836 STRLEN len;
a687059c 837
79072805
LW
838 /* assuming fp is checked earlier */
839 if (!sv)
840 return TRUE;
3280af22 841 if (PL_ofmt) {
8990e307 842 if (SvGMAGICAL(sv))
79072805 843 mg_get(sv);
463ee0b2 844 if (SvIOK(sv) && SvIVX(sv) != 0) {
3280af22 845 PerlIO_printf(fp, PL_ofmt, (double)SvIVX(sv));
760ac839 846 return !PerlIO_error(fp);
79072805 847 }
463ee0b2 848 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
79072805 849 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
3280af22 850 PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
760ac839 851 return !PerlIO_error(fp);
79072805 852 }
a687059c 853 }
79072805
LW
854 switch (SvTYPE(sv)) {
855 case SVt_NULL:
3280af22 856 if (PL_dowarn)
8990e307 857 warn(warn_uninit);
ff8e2863 858 return TRUE;
79072805 859 case SVt_IV:
a0d0e21e
LW
860 if (SvIOK(sv)) {
861 if (SvGMAGICAL(sv))
862 mg_get(sv);
760ac839
LW
863 PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
864 return !PerlIO_error(fp);
a0d0e21e
LW
865 }
866 /* FALL THROUGH */
79072805 867 default:
463ee0b2 868 tmps = SvPV(sv, len);
79072805 869 break;
ff8e2863 870 }
760ac839 871 if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
a687059c 872 return FALSE;
760ac839 873 return !PerlIO_error(fp);
a687059c
LW
874}
875
79072805 876I32
8ac85365 877my_stat(ARGSproto)
a687059c 878{
4e35701f 879 djSP;
79072805 880 IO *io;
748a9306 881 GV* tmpgv;
79072805 882
533c011a 883 if (PL_op->op_flags & OPf_REF) {
924508f0 884 EXTEND(SP,1);
748a9306
LW
885 tmpgv = cGVOP->op_gv;
886 do_fstat:
887 io = GvIO(tmpgv);
8990e307 888 if (io && IoIFP(io)) {
3280af22
NIS
889 PL_statgv = tmpgv;
890 sv_setpv(PL_statname,"");
891 PL_laststype = OP_STAT;
892 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
a687059c
LW
893 }
894 else {
3280af22
NIS
895 if (tmpgv == PL_defgv)
896 return PL_laststatval;
897 if (PL_dowarn)
a687059c 898 warn("Stat on unopened file <%s>",
748a9306 899 GvENAME(tmpgv));
3280af22
NIS
900 PL_statgv = Nullgv;
901 sv_setpv(PL_statname,"");
902 return (PL_laststatval = -1);
a687059c
LW
903 }
904 }
905 else {
748a9306 906 SV* sv = POPs;
4b74e3fb 907 char *s;
79072805 908 PUTBACK;
748a9306
LW
909 if (SvTYPE(sv) == SVt_PVGV) {
910 tmpgv = (GV*)sv;
911 goto do_fstat;
912 }
913 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
914 tmpgv = (GV*)SvRV(sv);
915 goto do_fstat;
916 }
917
3280af22
NIS
918 s = SvPV(sv, PL_na);
919 PL_statgv = Nullgv;
920 sv_setpv(PL_statname, s);
921 PL_laststype = OP_STAT;
922 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
923 if (PL_laststatval < 0 && PL_dowarn && strchr(s, '\n'))
bee1dbe2 924 warn(warn_nl, "stat");
3280af22 925 return PL_laststatval;
a687059c
LW
926 }
927}
928
79072805 929I32
8ac85365 930my_lstat(ARGSproto)
c623bd54 931{
4e35701f 932 djSP;
79072805 933 SV *sv;
533c011a 934 if (PL_op->op_flags & OPf_REF) {
924508f0 935 EXTEND(SP,1);
3280af22
NIS
936 if (cGVOP->op_gv == PL_defgv) {
937 if (PL_laststype != OP_LSTAT)
463ee0b2 938 croak("The stat preceding -l _ wasn't an lstat");
3280af22 939 return PL_laststatval;
fe14fcc3 940 }
463ee0b2 941 croak("You can't use -l on a filehandle");
fe14fcc3 942 }
c623bd54 943
3280af22
NIS
944 PL_laststype = OP_LSTAT;
945 PL_statgv = Nullgv;
79072805
LW
946 sv = POPs;
947 PUTBACK;
3280af22 948 sv_setpv(PL_statname,SvPV(sv, PL_na));
fe14fcc3 949#ifdef HAS_LSTAT
3280af22 950 PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache);
c623bd54 951#else
b28d0864 952 PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache);
c623bd54 953#endif
3280af22 954 if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
bee1dbe2 955 warn(warn_nl, "lstat");
3280af22 956 return PL_laststatval;
c623bd54
LW
957}
958
a687059c 959bool
8ac85365 960do_aexec(SV *really, register SV **mark, register SV **sp)
a687059c 961{
a687059c 962 register char **a;
a687059c
LW
963 char *tmps;
964
79072805 965 if (sp > mark) {
11343788 966 dTHR;
3280af22
NIS
967 New(401,PL_Argv, sp - mark + 1, char*);
968 a = PL_Argv;
79072805
LW
969 while (++mark <= sp) {
970 if (*mark)
3280af22 971 *a++ = SvPVx(*mark, PL_na);
a687059c
LW
972 else
973 *a++ = "";
974 }
975 *a = Nullch;
3280af22 976 if (*PL_Argv[0] != '/') /* will execvp use PATH? */
79072805 977 TAINT_ENV(); /* testing IFS here is overkill, probably */
3280af22
NIS
978 if (really && *(tmps = SvPV(really, PL_na)))
979 PerlProc_execvp(tmps,PL_Argv);
a687059c 980 else
3280af22
NIS
981 PerlProc_execvp(PL_Argv[0],PL_Argv);
982 if (PL_dowarn)
983 warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
a687059c 984 }
bee1dbe2 985 do_execfree();
a687059c
LW
986 return FALSE;
987}
988
fe14fcc3 989void
8ac85365 990do_execfree(void)
ff8e2863 991{
3280af22
NIS
992 if (PL_Argv) {
993 Safefree(PL_Argv);
994 PL_Argv = Null(char **);
ff8e2863 995 }
3280af22
NIS
996 if (PL_Cmd) {
997 Safefree(PL_Cmd);
998 PL_Cmd = Nullch;
ff8e2863
LW
999 }
1000}
1001
39e571d4 1002#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
760ac839 1003
a687059c 1004bool
8ac85365 1005do_exec(char *cmd)
a687059c
LW
1006{
1007 register char **a;
1008 register char *s;
a687059c
LW
1009 char flags[10];
1010
748a9306
LW
1011 while (*cmd && isSPACE(*cmd))
1012 cmd++;
1013
a687059c
LW
1014 /* save an extra exec if possible */
1015
bf38876a 1016#ifdef CSH
3280af22 1017 if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
a687059c 1018 strcpy(flags,"-c");
3280af22 1019 s = cmd+PL_cshlen+3;
a687059c
LW
1020 if (*s == 'f') {
1021 s++;
1022 strcat(flags,"f");
1023 }
1024 if (*s == ' ')
1025 s++;
1026 if (*s++ == '\'') {
1027 char *ncmd = s;
1028
1029 while (*s)
1030 s++;
1031 if (s[-1] == '\n')
1032 *--s = '\0';
1033 if (s[-1] == '\'') {
1034 *--s = '\0';
3280af22 1035 PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
a687059c
LW
1036 *s = '\'';
1037 return FALSE;
1038 }
1039 }
1040 }
bf38876a 1041#endif /* CSH */
a687059c
LW
1042
1043 /* see if there are shell metacharacters in it */
1044
748a9306
LW
1045 if (*cmd == '.' && isSPACE(cmd[1]))
1046 goto doshell;
1047
1048 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1049 goto doshell;
1050
99b89507 1051 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
63f2c1e1
LW
1052 if (*s == '=')
1053 goto doshell;
748a9306 1054
a687059c 1055 for (s = cmd; *s; s++) {
93a17b20 1056 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1057 if (*s == '\n' && !s[1]) {
1058 *s = '\0';
1059 break;
1060 }
1061 doshell:
3280af22 1062 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
a687059c
LW
1063 return FALSE;
1064 }
1065 }
748a9306 1066
3280af22
NIS
1067 New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1068 PL_Cmd = savepvn(cmd, s-cmd);
1069 a = PL_Argv;
1070 for (s = PL_Cmd; *s;) {
99b89507 1071 while (*s && isSPACE(*s)) s++;
a687059c
LW
1072 if (*s)
1073 *(a++) = s;
99b89507 1074 while (*s && !isSPACE(*s)) s++;
a687059c
LW
1075 if (*s)
1076 *s++ = '\0';
1077 }
1078 *a = Nullch;
3280af22
NIS
1079 if (PL_Argv[0]) {
1080 PerlProc_execvp(PL_Argv[0],PL_Argv);
b1248f16 1081 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1082 do_execfree();
a687059c 1083 goto doshell;
b1248f16 1084 }
3280af22
NIS
1085 if (PL_dowarn)
1086 warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
a687059c 1087 }
ff8e2863 1088 do_execfree();
a687059c
LW
1089 return FALSE;
1090}
1091
6890e559 1092#endif /* OS2 || WIN32 */
760ac839 1093
79072805 1094I32
8ac85365 1095apply(I32 type, register SV **mark, register SV **sp)
a687059c 1096{
11343788 1097 dTHR;
79072805
LW
1098 register I32 val;
1099 register I32 val2;
1100 register I32 tot = 0;
20408e3c 1101 char *what;
a687059c 1102 char *s;
79072805 1103 SV **oldmark = mark;
a687059c 1104
20408e3c 1105#define APPLY_TAINT_PROPER() \
3280af22
NIS
1106 STMT_START { \
1107 if (PL_tainting && PL_tainted) { goto taint_proper_label; } \
873ef191 1108 } STMT_END
20408e3c
GS
1109
1110 /* This is a first heuristic; it doesn't catch tainting magic. */
3280af22 1111 if (PL_tainting) {
463ee0b2 1112 while (++mark <= sp) {
bbce6d69
PP
1113 if (SvTAINTED(*mark)) {
1114 TAINT;
1115 break;
1116 }
463ee0b2
LW
1117 }
1118 mark = oldmark;
1119 }
a687059c 1120 switch (type) {
79072805 1121 case OP_CHMOD:
20408e3c
GS
1122 what = "chmod";
1123 APPLY_TAINT_PROPER();
79072805 1124 if (++mark <= sp) {
463ee0b2 1125 val = SvIVx(*mark);
20408e3c
GS
1126 APPLY_TAINT_PROPER();
1127 tot = sp - mark;
79072805 1128 while (++mark <= sp) {
3280af22 1129 char *name = SvPVx(*mark, PL_na);
20408e3c
GS
1130 APPLY_TAINT_PROPER();
1131 if (PerlLIO_chmod(name, val))
a687059c
LW
1132 tot--;
1133 }
1134 }
1135 break;
fe14fcc3 1136#ifdef HAS_CHOWN
79072805 1137 case OP_CHOWN:
20408e3c
GS
1138 what = "chown";
1139 APPLY_TAINT_PROPER();
79072805 1140 if (sp - mark > 2) {
463ee0b2
LW
1141 val = SvIVx(*++mark);
1142 val2 = SvIVx(*++mark);
20408e3c 1143 APPLY_TAINT_PROPER();
a0d0e21e 1144 tot = sp - mark;
79072805 1145 while (++mark <= sp) {
3280af22 1146 char *name = SvPVx(*mark, PL_na);
20408e3c 1147 APPLY_TAINT_PROPER();
36660982 1148 if (PerlLIO_chown(name, val, val2))
a687059c
LW
1149 tot--;
1150 }
1151 }
1152 break;
b1248f16 1153#endif
dd64f1c3
AD
1154/*
1155XXX Should we make lchown() directly available from perl?
1156For now, we'll let Configure test for HAS_LCHOWN, but do
1157nothing in the core.
1158 --AD 5/1998
1159*/
fe14fcc3 1160#ifdef HAS_KILL
79072805 1161 case OP_KILL:
20408e3c
GS
1162 what = "kill";
1163 APPLY_TAINT_PROPER();
55497cff
PP
1164 if (mark == sp)
1165 break;
3280af22 1166 s = SvPVx(*++mark, PL_na);
79072805
LW
1167 if (isUPPER(*s)) {
1168 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1169 s += 3;
1170 if (!(val = whichsig(s)))
463ee0b2 1171 croak("Unrecognized signal name \"%s\"",s);
79072805
LW
1172 }
1173 else
463ee0b2 1174 val = SvIVx(*mark);
20408e3c
GS
1175 APPLY_TAINT_PROPER();
1176 tot = sp - mark;
3595fcef
PP
1177#ifdef VMS
1178 /* kill() doesn't do process groups (job trees?) under VMS */
1179 if (val < 0) val = -val;
1180 if (val == SIGKILL) {
1181# include <starlet.h>
1182 /* Use native sys$delprc() to insure that target process is
1183 * deleted; supervisor-mode images don't pay attention to
1184 * CRTL's emulation of Unix-style signals and kill()
1185 */
1186 while (++mark <= sp) {
1187 I32 proc = SvIVx(*mark);
1188 register unsigned long int __vmssts;
20408e3c 1189 APPLY_TAINT_PROPER();
3595fcef
PP
1190 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1191 tot--;
1192 switch (__vmssts) {
1193 case SS$_NONEXPR:
1194 case SS$_NOSUCHNODE:
1195 SETERRNO(ESRCH,__vmssts);
1196 break;
1197 case SS$_NOPRIV:
1198 SETERRNO(EPERM,__vmssts);
1199 break;
1200 default:
1201 SETERRNO(EVMSERR,__vmssts);
1202 }
1203 }
1204 }
1205 break;
1206 }
1207#endif
79072805
LW
1208 if (val < 0) {
1209 val = -val;
1210 while (++mark <= sp) {
463ee0b2 1211 I32 proc = SvIVx(*mark);
20408e3c 1212 APPLY_TAINT_PROPER();
fe14fcc3 1213#ifdef HAS_KILLPG
3028581b 1214 if (PerlProc_killpg(proc,val)) /* BSD */
a687059c 1215#else
3028581b 1216 if (PerlProc_kill(-proc,val)) /* SYSV */
a687059c 1217#endif
79072805 1218 tot--;
a687059c 1219 }
79072805
LW
1220 }
1221 else {
1222 while (++mark <= sp) {
20408e3c
GS
1223 I32 proc = SvIVx(*mark);
1224 APPLY_TAINT_PROPER();
1225 if (PerlProc_kill(proc, val))
79072805 1226 tot--;
a687059c
LW
1227 }
1228 }
1229 break;
b1248f16 1230#endif
79072805 1231 case OP_UNLINK:
20408e3c
GS
1232 what = "unlink";
1233 APPLY_TAINT_PROPER();
79072805
LW
1234 tot = sp - mark;
1235 while (++mark <= sp) {
3280af22 1236 s = SvPVx(*mark, PL_na);
20408e3c 1237 APPLY_TAINT_PROPER();
3280af22 1238 if (PL_euid || PL_unsafe) {
a687059c
LW
1239 if (UNLINK(s))
1240 tot--;
1241 }
1242 else { /* don't let root wipe out directories without -U */
fe14fcc3 1243#ifdef HAS_LSTAT
3280af22 1244 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c 1245#else
b28d0864 1246 if (PerlLIO_stat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c 1247#endif
a687059c
LW
1248 tot--;
1249 else {
1250 if (UNLINK(s))
1251 tot--;
1252 }
1253 }
1254 }
1255 break;
a0d0e21e 1256#ifdef HAS_UTIME
79072805 1257 case OP_UTIME:
20408e3c
GS
1258 what = "utime";
1259 APPLY_TAINT_PROPER();
79072805 1260 if (sp - mark > 2) {
748a9306 1261#if defined(I_UTIME) || defined(VMS)
663a0e37
LW
1262 struct utimbuf utbuf;
1263#else
a687059c 1264 struct {
663a0e37
LW
1265 long actime;
1266 long modtime;
a687059c 1267 } utbuf;
663a0e37 1268#endif
a687059c 1269
afd9f252 1270 Zero(&utbuf, sizeof utbuf, char);
517844ec
PP
1271#ifdef BIG_TIME
1272 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1273 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
1274#else
463ee0b2
LW
1275 utbuf.actime = SvIVx(*++mark); /* time accessed */
1276 utbuf.modtime = SvIVx(*++mark); /* time modified */
517844ec 1277#endif
20408e3c 1278 APPLY_TAINT_PROPER();
79072805
LW
1279 tot = sp - mark;
1280 while (++mark <= sp) {
3280af22 1281 char *name = SvPVx(*mark, PL_na);
20408e3c
GS
1282 APPLY_TAINT_PROPER();
1283 if (PerlLIO_utime(name, &utbuf))
a687059c
LW
1284 tot--;
1285 }
a687059c
LW
1286 }
1287 else
79072805 1288 tot = 0;
a687059c 1289 break;
a0d0e21e 1290#endif
a687059c
LW
1291 }
1292 return tot;
20408e3c 1293
873ef191 1294 taint_proper_label:
20408e3c
GS
1295 TAINT_PROPER(what);
1296 return 0; /* this should never happen */
1297
1298#undef APPLY_TAINT_PROPER
a687059c
LW
1299}
1300
1301/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1302#ifndef VMS /* VMS' cando is in vms.c */
79072805 1303I32
8ac85365 1304cando(I32 bit, I32 effective, register struct stat *statbufp)
a687059c 1305{
bee1dbe2 1306#ifdef DOSISH
fe14fcc3
LW
1307 /* [Comments and code from Len Reed]
1308 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1309 * to write-protected files. The execute permission bit is set
1310 * by the Miscrosoft C library stat() function for the following:
1311 * .exe files
1312 * .com files
1313 * .bat files
1314 * directories
1315 * All files and directories are readable.
1316 * Directories and special files, e.g. "CON", cannot be
1317 * write-protected.
1318 * [Comment by Tom Dinger -- a directory can have the write-protect
1319 * bit set in the file system, but DOS permits changes to
1320 * the directory anyway. In addition, all bets are off
1321 * here for networked software, such as Novell and
1322 * Sun's PC-NFS.]
1323 */
1324
bee1dbe2
LW
1325 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1326 * too so it will actually look into the files for magic numbers
1327 */
fe14fcc3
LW
1328 return (bit & statbufp->st_mode) ? TRUE : FALSE;
1329
55497cff 1330#else /* ! DOSISH */
3280af22 1331 if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
c623bd54
LW
1332 if (bit == S_IXUSR) {
1333 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1334 return TRUE;
1335 }
1336 else
1337 return TRUE; /* root reads and writes anything */
1338 return FALSE;
1339 }
3280af22 1340 if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
a687059c
LW
1341 if (statbufp->st_mode & bit)
1342 return TRUE; /* ok as "user" */
1343 }
79072805 1344 else if (ingroup((I32)statbufp->st_gid,effective)) {
a687059c
LW
1345 if (statbufp->st_mode & bit >> 3)
1346 return TRUE; /* ok as "group" */
1347 }
1348 else if (statbufp->st_mode & bit >> 6)
1349 return TRUE; /* ok as "other" */
1350 return FALSE;
55497cff 1351#endif /* ! DOSISH */
a687059c 1352}
a0d0e21e 1353#endif /* ! VMS */
a687059c 1354
79072805 1355I32
8ac85365 1356ingroup(I32 testgid, I32 effective)
a687059c 1357{
3280af22 1358 if (testgid == (effective ? PL_egid : PL_gid))
a687059c 1359 return TRUE;
fe14fcc3 1360#ifdef HAS_GETGROUPS
a687059c
LW
1361#ifndef NGROUPS
1362#define NGROUPS 32
1363#endif
1364 {
a0d0e21e 1365 Groups_t gary[NGROUPS];
79072805 1366 I32 anum;
a687059c
LW
1367
1368 anum = getgroups(NGROUPS,gary);
1369 while (--anum >= 0)
1370 if (gary[anum] == testgid)
1371 return TRUE;
1372 }
1373#endif
1374 return FALSE;
1375}
c2ab57d4 1376
fe14fcc3 1377#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1378
79072805 1379I32
8ac85365 1380do_ipcget(I32 optype, SV **mark, SV **sp)
c2ab57d4 1381{
11343788 1382 dTHR;
c2ab57d4 1383 key_t key;
79072805 1384 I32 n, flags;
c2ab57d4 1385
463ee0b2
LW
1386 key = (key_t)SvNVx(*++mark);
1387 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1388 flags = SvIVx(*++mark);
748a9306 1389 SETERRNO(0,0);
c2ab57d4
LW
1390 switch (optype)
1391 {
fe14fcc3 1392#ifdef HAS_MSG
79072805 1393 case OP_MSGGET:
c2ab57d4 1394 return msgget(key, flags);
e5d73d77 1395#endif
fe14fcc3 1396#ifdef HAS_SEM
79072805 1397 case OP_SEMGET:
c2ab57d4 1398 return semget(key, n, flags);
e5d73d77 1399#endif
fe14fcc3 1400#ifdef HAS_SHM
79072805 1401 case OP_SHMGET:
c2ab57d4 1402 return shmget(key, n, flags);
e5d73d77 1403#endif
fe14fcc3 1404#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1405 default:
c07a80fd 1406 croak("%s not implemented", op_desc[optype]);
e5d73d77 1407#endif
c2ab57d4
LW
1408 }
1409 return -1; /* should never happen */
1410}
1411
79072805 1412I32
8ac85365 1413do_ipcctl(I32 optype, SV **mark, SV **sp)
c2ab57d4 1414{
11343788 1415 dTHR;
79072805 1416 SV *astr;
c2ab57d4 1417 char *a;
a0d0e21e
LW
1418 I32 id, n, cmd, infosize, getinfo;
1419 I32 ret = -1;
c2ab57d4 1420
463ee0b2
LW
1421 id = SvIVx(*++mark);
1422 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1423 cmd = SvIVx(*++mark);
79072805 1424 astr = *++mark;
c2ab57d4
LW
1425 infosize = 0;
1426 getinfo = (cmd == IPC_STAT);
1427
1428 switch (optype)
1429 {
fe14fcc3 1430#ifdef HAS_MSG
79072805 1431 case OP_MSGCTL:
c2ab57d4
LW
1432 if (cmd == IPC_STAT || cmd == IPC_SET)
1433 infosize = sizeof(struct msqid_ds);
1434 break;
e5d73d77 1435#endif
fe14fcc3 1436#ifdef HAS_SHM
79072805 1437 case OP_SHMCTL:
c2ab57d4
LW
1438 if (cmd == IPC_STAT || cmd == IPC_SET)
1439 infosize = sizeof(struct shmid_ds);
1440 break;
e5d73d77 1441#endif
fe14fcc3 1442#ifdef HAS_SEM
79072805 1443 case OP_SEMCTL:
c2ab57d4
LW
1444 if (cmd == IPC_STAT || cmd == IPC_SET)
1445 infosize = sizeof(struct semid_ds);
1446 else if (cmd == GETALL || cmd == SETALL)
1447 {
8e591e46 1448 struct semid_ds semds;
bd89102f
AD
1449 union semun semun;
1450
84902520 1451 semun.buf = &semds;
c2ab57d4 1452 getinfo = (cmd == GETALL);
9b89d93d
GB
1453 if (Semctl(id, 0, IPC_STAT, semun) == -1)
1454 return -1;
6e21c824
LW
1455 infosize = semds.sem_nsems * sizeof(short);
1456 /* "short" is technically wrong but much more portable
1457 than guessing about u_?short(_t)? */
c2ab57d4
LW
1458 }
1459 break;
e5d73d77 1460#endif
fe14fcc3 1461#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1462 default:
c07a80fd 1463 croak("%s not implemented", op_desc[optype]);
e5d73d77 1464#endif
c2ab57d4
LW
1465 }
1466
1467 if (infosize)
1468 {
a0d0e21e 1469 STRLEN len;
c2ab57d4
LW
1470 if (getinfo)
1471 {
a0d0e21e
LW
1472 SvPV_force(astr, len);
1473 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
1474 }
1475 else
1476 {
463ee0b2
LW
1477 a = SvPV(astr, len);
1478 if (len != infosize)
9607fc9c
PP
1479 croak("Bad arg length for %s, is %lu, should be %ld",
1480 op_desc[optype], (unsigned long)len, (long)infosize);
c2ab57d4
LW
1481 }
1482 }
1483 else
1484 {
c030ccd9 1485 IV i = SvIV(astr);
c2ab57d4
LW
1486 a = (char *)i; /* ouch */
1487 }
748a9306 1488 SETERRNO(0,0);
c2ab57d4
LW
1489 switch (optype)
1490 {
fe14fcc3 1491#ifdef HAS_MSG
79072805 1492 case OP_MSGCTL:
bee1dbe2 1493 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 1494 break;
e5d73d77 1495#endif
fe14fcc3 1496#ifdef HAS_SEM
bd89102f
AD
1497 case OP_SEMCTL: {
1498 union semun unsemds;
1499
1500 unsemds.buf = (struct semid_ds *)a;
1501 ret = Semctl(id, n, cmd, unsemds);
1502 }
c2ab57d4 1503 break;
e5d73d77 1504#endif
fe14fcc3 1505#ifdef HAS_SHM
79072805 1506 case OP_SHMCTL:
bee1dbe2 1507 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 1508 break;
e5d73d77 1509#endif
c2ab57d4
LW
1510 }
1511 if (getinfo && ret >= 0) {
79072805
LW
1512 SvCUR_set(astr, infosize);
1513 *SvEND(astr) = '\0';
a0d0e21e 1514 SvSETMAGIC(astr);
c2ab57d4
LW
1515 }
1516 return ret;
1517}
1518
79072805 1519I32
8ac85365 1520do_msgsnd(SV **mark, SV **sp)
c2ab57d4 1521{
fe14fcc3 1522#ifdef HAS_MSG
11343788 1523 dTHR;
79072805 1524 SV *mstr;
c2ab57d4 1525 char *mbuf;
79072805 1526 I32 id, msize, flags;
463ee0b2 1527 STRLEN len;
c2ab57d4 1528
463ee0b2 1529 id = SvIVx(*++mark);
79072805 1530 mstr = *++mark;
463ee0b2
LW
1531 flags = SvIVx(*++mark);
1532 mbuf = SvPV(mstr, len);
1533 if ((msize = len - sizeof(long)) < 0)
1534 croak("Arg too short for msgsnd");
748a9306 1535 SETERRNO(0,0);
bee1dbe2 1536 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 1537#else
463ee0b2 1538 croak("msgsnd not implemented");
e5d73d77 1539#endif
c2ab57d4
LW
1540}
1541
79072805 1542I32
8ac85365 1543do_msgrcv(SV **mark, SV **sp)
c2ab57d4 1544{
fe14fcc3 1545#ifdef HAS_MSG
11343788 1546 dTHR;
79072805 1547 SV *mstr;
c2ab57d4
LW
1548 char *mbuf;
1549 long mtype;
79072805 1550 I32 id, msize, flags, ret;
463ee0b2 1551 STRLEN len;
79072805 1552
463ee0b2 1553 id = SvIVx(*++mark);
79072805 1554 mstr = *++mark;
463ee0b2
LW
1555 msize = SvIVx(*++mark);
1556 mtype = (long)SvIVx(*++mark);
1557 flags = SvIVx(*++mark);
ed6116ce
LW
1558 if (SvTHINKFIRST(mstr)) {
1559 if (SvREADONLY(mstr))
1560 croak("Can't msgrcv to readonly var");
1561 if (SvROK(mstr))
1562 sv_unref(mstr);
1563 }
a0d0e21e
LW
1564 SvPV_force(mstr, len);
1565 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1566
748a9306 1567 SETERRNO(0,0);
bee1dbe2 1568 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 1569 if (ret >= 0) {
79072805
LW
1570 SvCUR_set(mstr, sizeof(long)+ret);
1571 *SvEND(mstr) = '\0';
c2ab57d4
LW
1572 }
1573 return ret;
e5d73d77 1574#else
463ee0b2 1575 croak("msgrcv not implemented");
e5d73d77 1576#endif
c2ab57d4
LW
1577}
1578
79072805 1579I32
8ac85365 1580do_semop(SV **mark, SV **sp)
c2ab57d4 1581{
fe14fcc3 1582#ifdef HAS_SEM
11343788 1583 dTHR;
79072805 1584 SV *opstr;
c2ab57d4 1585 char *opbuf;
463ee0b2
LW
1586 I32 id;
1587 STRLEN opsize;
c2ab57d4 1588
463ee0b2 1589 id = SvIVx(*++mark);
79072805 1590 opstr = *++mark;
463ee0b2 1591 opbuf = SvPV(opstr, opsize);
c2ab57d4
LW
1592 if (opsize < sizeof(struct sembuf)
1593 || (opsize % sizeof(struct sembuf)) != 0) {
748a9306 1594 SETERRNO(EINVAL,LIB$_INVARG);
c2ab57d4
LW
1595 return -1;
1596 }
748a9306 1597 SETERRNO(0,0);
6e21c824 1598 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
e5d73d77 1599#else
463ee0b2 1600 croak("semop not implemented");
e5d73d77 1601#endif
c2ab57d4
LW
1602}
1603
79072805 1604I32
8ac85365 1605do_shmio(I32 optype, SV **mark, SV **sp)
c2ab57d4 1606{
fe14fcc3 1607#ifdef HAS_SHM
11343788 1608 dTHR;
79072805 1609 SV *mstr;
c2ab57d4 1610 char *mbuf, *shm;
79072805 1611 I32 id, mpos, msize;
463ee0b2 1612 STRLEN len;
c2ab57d4 1613 struct shmid_ds shmds;
c2ab57d4 1614
463ee0b2 1615 id = SvIVx(*++mark);
79072805 1616 mstr = *++mark;
463ee0b2
LW
1617 mpos = SvIVx(*++mark);
1618 msize = SvIVx(*++mark);
748a9306 1619 SETERRNO(0,0);
c2ab57d4
LW
1620 if (shmctl(id, IPC_STAT, &shmds) == -1)
1621 return -1;
1622 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
748a9306 1623 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
1624 return -1;
1625 }
8ac85365 1626 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
1627 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1628 return -1;
79072805 1629 if (optype == OP_SHMREAD) {
a0d0e21e
LW
1630 SvPV_force(mstr, len);
1631 mbuf = SvGROW(mstr, msize+1);
1632
bee1dbe2 1633 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
1634 SvCUR_set(mstr, msize);
1635 *SvEND(mstr) = '\0';
a0d0e21e 1636 SvSETMAGIC(mstr);
c2ab57d4
LW
1637 }
1638 else {
79072805 1639 I32 n;
c2ab57d4 1640
a0d0e21e 1641 mbuf = SvPV(mstr, len);
463ee0b2 1642 if ((n = len) > msize)
c2ab57d4 1643 n = msize;
bee1dbe2 1644 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 1645 if (n < msize)
bee1dbe2 1646 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
1647 }
1648 return shmdt(shm);
e5d73d77 1649#else
463ee0b2 1650 croak("shm I/O not implemented");
e5d73d77 1651#endif
c2ab57d4
LW
1652}
1653
fe14fcc3 1654#endif /* SYSV IPC */
4e35701f 1655