This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH 5.004_65] Config_65-02-03.diff: SunOS and Solaris hints
[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
a687059c 97 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;
6e21c824 103 else if (fd <= 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));
6e21c824 121 if (result == EOF && fd > 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' ;
176 if (dowarn)
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
LW
260 }
261 else if (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) {
8990e307 286 if (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;
3028581b 293 if (PerlLIO_fstat(PerlIO_fileno(fp),&statbuf) < 0) {
760ac839 294 (void)PerlIO_close(fp);
6e21c824 295 goto say_false;
a687059c 296 }
1462b684 297 if (S_ISSOCK(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
99b89507
LW
302 !(statbuf.st_mode & S_IFMT)
303#else
304 !statbuf.st_mode
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);
760ac839 332 sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
a0d0e21e 333 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2
LW
334 pid = SvIVX(sv);
335 SvIVX(sv) = 0;
79072805 336 sv = *av_fetch(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);
a0d0e21e 348 fcntl(fd,F_SETFD,fd > maxsysfd);
1462b684 349#endif
8990e307 350 IoIFP(io) = fp;
bf38876a 351 if (writing) {
96827780 352 dTHR;
8990e307
LW
353 if (IoTYPE(io) == 's'
354 || (IoTYPE(io) == '>' && S_ISCHR(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
79072805 384 if (!argvoutgv)
85e6fe83 385 argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
fe14fcc3 386 if (filemode & (S_ISUID|S_ISGID)) {
760ac839 387 PerlIO_flush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */
fe14fcc3
LW
388#ifdef HAS_FCHMOD
389 (void)fchmod(lastfd,filemode);
390#else
3028581b 391 (void)PerlLIO_chmod(oldname,filemode);
fe14fcc3
LW
392#endif
393 }
394 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));
85aff577
CS
402 oldname = SvPVx(GvSV(gv), oldlen);
403 if (do_open(gv,oldname,oldlen,inplace!=0,0,0,Nullfp)) {
a687059c 404 if (inplace) {
79072805 405 TAINT_PROPER("inplace open");
85aff577 406 if (oldlen == 1 && *oldname == '-') {
4633a7c4 407 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a0d0e21e 408 return IoIFP(GvIOp(gv));
c623bd54 409 }
99b89507 410#ifndef FLEXFILENAMES
c623bd54
LW
411 filedev = statbuf.st_dev;
412 fileino = statbuf.st_ino;
99b89507 413#endif
a687059c
LW
414 filemode = statbuf.st_mode;
415 fileuid = statbuf.st_uid;
416 filegid = statbuf.st_gid;
c623bd54
LW
417 if (!S_ISREG(filemode)) {
418 warn("Can't do inplace edit: %s is not a regular file",
419 oldname );
79072805 420 do_close(gv,FALSE);
c623bd54
LW
421 continue;
422 }
a687059c 423 if (*inplace) {
ff8e2863 424#ifdef SUFFIX
79072805 425 add_suffix(sv,inplace);
ff8e2863 426#else
79072805 427 sv_catpv(sv,inplace);
ff8e2863 428#endif
c623bd54 429#ifndef FLEXFILENAMES
3028581b 430 if (PerlLIO_stat(SvPVX(sv),&statbuf) >= 0
c623bd54 431 && statbuf.st_dev == filedev
39e571d4
ML
432 && statbuf.st_ino == fileino
433#ifdef DJGPP
434 || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
435#endif
436 ) {
437 warn("Can't do inplace edit: %s would not be uniq",
463ee0b2 438 SvPVX(sv) );
79072805 439 do_close(gv,FALSE);
c623bd54
LW
440 continue;
441 }
442#endif
fe14fcc3 443#ifdef HAS_RENAME
bee1dbe2 444#ifndef DOSISH
3028581b 445 if (PerlLIO_rename(oldname,SvPVX(sv)) < 0) {
c623bd54 446 warn("Can't rename %s to %s: %s, skipping file",
2304df62 447 oldname, SvPVX(sv), Strerror(errno) );
79072805 448 do_close(gv,FALSE);
c623bd54
LW
449 continue;
450 }
a687059c 451#else
79072805 452 do_close(gv,FALSE);
3028581b
GS
453 (void)PerlLIO_unlink(SvPVX(sv));
454 (void)PerlLIO_rename(oldname,SvPVX(sv));
85aff577 455 do_open(gv,SvPVX(sv),SvCUR(sv),inplace!=0,0,0,Nullfp);
55497cff 456#endif /* DOSISH */
ff8e2863 457#else
463ee0b2
LW
458 (void)UNLINK(SvPVX(sv));
459 if (link(oldname,SvPVX(sv)) < 0) {
c623bd54 460 warn("Can't rename %s to %s: %s, skipping file",
2304df62 461 oldname, SvPVX(sv), Strerror(errno) );
79072805 462 do_close(gv,FALSE);
c623bd54
LW
463 continue;
464 }
a687059c
LW
465 (void)UNLINK(oldname);
466#endif
467 }
468 else {
a8c18271 469#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 470# ifndef VMS /* Don't delete; use automatic file versioning */
fe14fcc3 471 if (UNLINK(oldname) < 0) {
85aff577
CS
472 warn("Can't remove %s: %s, skipping file",
473 oldname, Strerror(errno) );
79072805 474 do_close(gv,FALSE);
fe14fcc3
LW
475 continue;
476 }
edc7bc49 477# endif
ff8e2863 478#else
463ee0b2 479 croak("Can't do inplace edit without backup");
ff8e2863 480#endif
a687059c
LW
481 }
482
85aff577
CS
483 sv_setpvn(sv,">",!inplace);
484 sv_catpvn(sv,oldname,oldlen);
748a9306 485 SETERRNO(0,0); /* in case sprintf set errno */
85aff577
CS
486 if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),inplace!=0,
487 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
c623bd54 488 warn("Can't do inplace edit on %s: %s",
2304df62 489 oldname, Strerror(errno) );
79072805 490 do_close(gv,FALSE);
fe14fcc3
LW
491 continue;
492 }
4633a7c4 493 setdefout(argvoutgv);
760ac839 494 lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
3028581b 495 (void)PerlLIO_fstat(lastfd,&statbuf);
fe14fcc3
LW
496#ifdef HAS_FCHMOD
497 (void)fchmod(lastfd,filemode);
a687059c 498#else
3e3baf6d
TB
499# if !(defined(WIN32) && defined(__BORLANDC__))
500 /* Borland runtime creates a readonly file! */
3028581b 501 (void)PerlLIO_chmod(oldname,filemode);
3e3baf6d 502# endif
a687059c 503#endif
fe14fcc3
LW
504 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
505#ifdef HAS_FCHOWN
506 (void)fchown(lastfd,fileuid,filegid);
a687059c 507#else
fe14fcc3
LW
508#ifdef HAS_CHOWN
509 (void)chown(oldname,fileuid,filegid);
a687059c 510#endif
b1248f16 511#endif
fe14fcc3 512 }
a687059c 513 }
a0d0e21e 514 return IoIFP(GvIOp(gv));
a687059c
LW
515 }
516 else
22fae026
TM
517 PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
518 SvPV(sv, na), Strerror(errno));
a687059c
LW
519 }
520 if (inplace) {
79072805 521 (void)do_close(argvoutgv,FALSE);
4633a7c4 522 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a687059c
LW
523 }
524 return Nullfp;
525}
526
fe14fcc3 527#ifdef HAS_PIPE
afd9f252 528void
8ac85365 529do_pipe(SV *sv, GV *rgv, GV *wgv)
afd9f252 530{
79072805
LW
531 register IO *rstio;
532 register IO *wstio;
afd9f252
LW
533 int fd[2];
534
79072805 535 if (!rgv)
afd9f252 536 goto badexit;
79072805 537 if (!wgv)
afd9f252
LW
538 goto badexit;
539
a0d0e21e
LW
540 rstio = GvIOn(rgv);
541 wstio = GvIOn(wgv);
afd9f252 542
a0d0e21e 543 if (IoIFP(rstio))
79072805 544 do_close(rgv,FALSE);
a0d0e21e 545 if (IoIFP(wstio))
79072805 546 do_close(wgv,FALSE);
afd9f252 547
3028581b 548 if (PerlProc_pipe(fd) < 0)
afd9f252 549 goto badexit;
760ac839
LW
550 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
551 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
8990e307
LW
552 IoIFP(wstio) = IoOFP(wstio);
553 IoTYPE(rstio) = '<';
554 IoTYPE(wstio) = '>';
555 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 556 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
3028581b 557 else PerlLIO_close(fd[0]);
760ac839 558 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
3028581b 559 else PerlLIO_close(fd[1]);
fe14fcc3
LW
560 goto badexit;
561 }
afd9f252 562
79072805 563 sv_setsv(sv,&sv_yes);
afd9f252
LW
564 return;
565
566badexit:
79072805 567 sv_setsv(sv,&sv_undef);
afd9f252
LW
568 return;
569}
b1248f16 570#endif
afd9f252 571
517844ec 572/* explicit renamed to avoid C++ conflict -- kja */
a687059c 573bool
517844ec 574do_close(GV *gv, bool not_implicit)
a687059c 575{
1193dd27
IZ
576 bool retval;
577 IO *io;
a687059c 578
79072805
LW
579 if (!gv)
580 gv = argvgv;
a0d0e21e 581 if (!gv || SvTYPE(gv) != SVt_PVGV) {
748a9306 582 SETERRNO(EBADF,SS$_IVCHAN);
c2ab57d4 583 return FALSE;
99b89507 584 }
79072805
LW
585 io = GvIO(gv);
586 if (!io) { /* never opened */
517844ec 587 if (dowarn && not_implicit)
79072805 588 warn("Close on unopened file <%s>",GvENAME(gv));
20408e3c 589 SETERRNO(EBADF,SS$_IVCHAN);
a687059c
LW
590 return FALSE;
591 }
1193dd27 592 retval = io_close(io);
517844ec 593 if (not_implicit) {
1193dd27
IZ
594 IoLINES(io) = 0;
595 IoPAGE(io) = 0;
596 IoLINES_LEFT(io) = IoPAGE_LEN(io);
597 }
598 IoTYPE(io) = ' ';
599 return retval;
600}
601
602bool
8ac85365 603io_close(IO *io)
1193dd27
IZ
604{
605 bool retval = FALSE;
606 int status;
607
8990e307
LW
608 if (IoIFP(io)) {
609 if (IoTYPE(io) == '|') {
3028581b 610 status = PerlProc_pclose(IoIFP(io));
f86702cc 611 STATUS_NATIVE_SET(status);
1e422769 612 retval = (STATUS_POSIX == 0);
a687059c 613 }
8990e307 614 else if (IoTYPE(io) == '-')
a687059c
LW
615 retval = TRUE;
616 else {
8990e307 617 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
760ac839
LW
618 retval = (PerlIO_close(IoOFP(io)) != EOF);
619 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
620 }
621 else
760ac839 622 retval = (PerlIO_close(IoIFP(io)) != EOF);
a687059c 623 }
8990e307 624 IoOFP(io) = IoIFP(io) = Nullfp;
79072805 625 }
20408e3c
GS
626 else {
627 SETERRNO(EBADF,SS$_IVCHAN);
628 }
1193dd27 629
a687059c
LW
630 return retval;
631}
632
633bool
8ac85365 634do_eof(GV *gv)
a687059c 635{
11343788 636 dTHR;
79072805 637 register IO *io;
a687059c
LW
638 int ch;
639
79072805 640 io = GvIO(gv);
a687059c 641
79072805 642 if (!io)
a687059c
LW
643 return TRUE;
644
8990e307 645 while (IoIFP(io)) {
a687059c 646
760ac839
LW
647 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
648 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
649 return FALSE; /* this is the most usual case */
650 }
a687059c 651
760ac839 652 ch = PerlIO_getc(IoIFP(io));
a687059c 653 if (ch != EOF) {
760ac839 654 (void)PerlIO_ungetc(IoIFP(io),ch);
a687059c
LW
655 return FALSE;
656 }
760ac839
LW
657 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
658 if (PerlIO_get_cnt(IoIFP(io)) < -1)
659 PerlIO_set_cnt(IoIFP(io),-1);
660 }
8990e307 661 if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
79072805 662 if (!nextargv(argvgv)) /* get another fp handy */
a687059c
LW
663 return TRUE;
664 }
665 else
666 return TRUE; /* normal fp, definitely end of file */
667 }
668 return TRUE;
669}
670
671long
8ac85365 672do_tell(GV *gv)
a687059c 673{
79072805 674 register IO *io;
96e4d5b1 675 register PerlIO *fp;
a687059c 676
96e4d5b1 677 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 678#ifdef ULTRIX_STDIO_BOTCH
96e4d5b1
PP
679 if (PerlIO_eof(fp))
680 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 681#endif
8903cb82 682 return PerlIO_tell(fp);
96e4d5b1 683 }
a687059c 684 if (dowarn)
8903cb82 685 warn("tell() on unopened file");
748a9306 686 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
687 return -1L;
688}
689
690bool
8ac85365 691do_seek(GV *gv, long int pos, int whence)
a687059c 692{
79072805 693 register IO *io;
137443ea 694 register PerlIO *fp;
a687059c 695
137443ea 696 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 697#ifdef ULTRIX_STDIO_BOTCH
137443ea
PP
698 if (PerlIO_eof(fp))
699 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 700#endif
8903cb82 701 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 702 }
a687059c 703 if (dowarn)
8903cb82 704 warn("seek() on unopened file");
748a9306 705 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
706 return FALSE;
707}
708
8903cb82 709long
8ac85365 710do_sysseek(GV *gv, long int pos, int whence)
8903cb82
PP
711{
712 register IO *io;
713 register PerlIO *fp;
714
715 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
3028581b 716 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
8903cb82
PP
717 if (dowarn)
718 warn("sysseek() on unopened file");
719 SETERRNO(EBADF,RMS$_IFI);
720 return -1L;
721}
722
6ff81951
GS
723int
724do_binmode(PerlIO *fp, int iotype, int flag)
725{
726 if (flag != TRUE)
727 croak("panic: unsetting binmode"); /* Not implemented yet */
728#ifdef DOSISH
729#ifdef atarist
730 if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
731 return 1;
732 else
733 return 0;
734#else
735 if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
736#if defined(WIN32) && defined(__BORLANDC__)
737 /* The translation mode of the stream is maintained independent
738 * of the translation mode of the fd in the Borland RTL (heavy
739 * digging through their runtime sources reveal). User has to
740 * set the mode explicitly for the stream (though they don't
741 * document this anywhere). GSAR 97-5-24
742 */
743 PerlIO_seek(fp,0L,0);
744 fp->flags |= _F_BIN;
745#endif
746 return 1;
747 }
748 else
749 return 0;
750#endif
751#else
752#if defined(USEMYBINMODE)
753 if (my_binmode(fp,iotype) != NULL)
754 return 1;
755 else
756 return 0;
757#else
758 return 1;
759#endif
760#endif
761}
762
a0d0e21e 763#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
c2ab57d4 764 /* code courtesy of William Kucharski */
fe14fcc3 765#define HAS_CHSIZE
6eb13c3b 766
517844ec 767I32 my_chsize(fd, length)
79072805 768I32 fd; /* file descriptor */
85e6fe83 769Off_t length; /* length to set file to */
6eb13c3b 770{
6eb13c3b
LW
771 struct flock fl;
772 struct stat filebuf;
773
3028581b 774 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
775 return -1;
776
777 if (filebuf.st_size < length) {
778
779 /* extend file length */
780
3028581b 781 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
782 return -1;
783
784 /* write a "0" byte */
785
3028581b 786 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
787 return -1;
788 }
789 else {
790 /* truncate length */
791
792 fl.l_whence = 0;
793 fl.l_len = 0;
794 fl.l_start = length;
a0d0e21e 795 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
796
797 /*
a0d0e21e 798 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
799 * fcntl(2), which truncates the file so that it ends at the
800 * position indicated by fl.l_start.
801 *
802 * Will minor miracles never cease?
803 */
804
a0d0e21e 805 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
806 return -1;
807
808 }
809
810 return 0;
811}
a0d0e21e 812#endif /* F_FREESP */
ff8e2863 813
a687059c 814bool
6acef3b7 815do_print(register SV *sv, PerlIO *fp)
a687059c
LW
816{
817 register char *tmps;
463ee0b2 818 STRLEN len;
a687059c 819
79072805
LW
820 /* assuming fp is checked earlier */
821 if (!sv)
822 return TRUE;
823 if (ofmt) {
8990e307 824 if (SvGMAGICAL(sv))
79072805 825 mg_get(sv);
463ee0b2 826 if (SvIOK(sv) && SvIVX(sv) != 0) {
760ac839
LW
827 PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
828 return !PerlIO_error(fp);
79072805 829 }
463ee0b2 830 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
79072805 831 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
760ac839
LW
832 PerlIO_printf(fp, ofmt, SvNVX(sv));
833 return !PerlIO_error(fp);
79072805 834 }
a687059c 835 }
79072805
LW
836 switch (SvTYPE(sv)) {
837 case SVt_NULL:
8990e307
LW
838 if (dowarn)
839 warn(warn_uninit);
ff8e2863 840 return TRUE;
79072805 841 case SVt_IV:
a0d0e21e
LW
842 if (SvIOK(sv)) {
843 if (SvGMAGICAL(sv))
844 mg_get(sv);
760ac839
LW
845 PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
846 return !PerlIO_error(fp);
a0d0e21e
LW
847 }
848 /* FALL THROUGH */
79072805 849 default:
463ee0b2 850 tmps = SvPV(sv, len);
79072805 851 break;
ff8e2863 852 }
760ac839 853 if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
a687059c 854 return FALSE;
760ac839 855 return !PerlIO_error(fp);
a687059c
LW
856}
857
79072805 858I32
8ac85365 859my_stat(ARGSproto)
a687059c 860{
4e35701f 861 djSP;
79072805 862 IO *io;
748a9306 863 GV* tmpgv;
79072805 864
a0d0e21e 865 if (op->op_flags & OPf_REF) {
924508f0 866 EXTEND(SP,1);
748a9306
LW
867 tmpgv = cGVOP->op_gv;
868 do_fstat:
869 io = GvIO(tmpgv);
8990e307 870 if (io && IoIFP(io)) {
748a9306 871 statgv = tmpgv;
79072805
LW
872 sv_setpv(statname,"");
873 laststype = OP_STAT;
3028581b 874 return (laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache));
a687059c
LW
875 }
876 else {
748a9306 877 if (tmpgv == defgv)
57ebbfd0 878 return laststatval;
a687059c
LW
879 if (dowarn)
880 warn("Stat on unopened file <%s>",
748a9306 881 GvENAME(tmpgv));
79072805
LW
882 statgv = Nullgv;
883 sv_setpv(statname,"");
57ebbfd0 884 return (laststatval = -1);
a687059c
LW
885 }
886 }
887 else {
748a9306 888 SV* sv = POPs;
4b74e3fb 889 char *s;
79072805 890 PUTBACK;
748a9306
LW
891 if (SvTYPE(sv) == SVt_PVGV) {
892 tmpgv = (GV*)sv;
893 goto do_fstat;
894 }
895 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
896 tmpgv = (GV*)SvRV(sv);
897 goto do_fstat;
898 }
899
4b74e3fb 900 s = SvPV(sv, na);
79072805 901 statgv = Nullgv;
4b74e3fb 902 sv_setpv(statname, s);
79072805 903 laststype = OP_STAT;
4b74e3fb
HS
904 laststatval = PerlLIO_stat(s, &statcache);
905 if (laststatval < 0 && dowarn && strchr(s, '\n'))
bee1dbe2
LW
906 warn(warn_nl, "stat");
907 return laststatval;
a687059c
LW
908 }
909}
910
79072805 911I32
8ac85365 912my_lstat(ARGSproto)
c623bd54 913{
4e35701f 914 djSP;
79072805 915 SV *sv;
a0d0e21e 916 if (op->op_flags & OPf_REF) {
924508f0 917 EXTEND(SP,1);
79072805
LW
918 if (cGVOP->op_gv == defgv) {
919 if (laststype != OP_LSTAT)
463ee0b2 920 croak("The stat preceding -l _ wasn't an lstat");
fe14fcc3
LW
921 return laststatval;
922 }
463ee0b2 923 croak("You can't use -l on a filehandle");
fe14fcc3 924 }
c623bd54 925
79072805
LW
926 laststype = OP_LSTAT;
927 statgv = Nullgv;
928 sv = POPs;
929 PUTBACK;
463ee0b2 930 sv_setpv(statname,SvPV(sv, na));
fe14fcc3 931#ifdef HAS_LSTAT
3028581b 932 laststatval = PerlLIO_lstat(SvPV(sv, na),&statcache);
c623bd54 933#else
3028581b 934 laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
c623bd54 935#endif
463ee0b2 936 if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
bee1dbe2
LW
937 warn(warn_nl, "lstat");
938 return laststatval;
c623bd54
LW
939}
940
a687059c 941bool
8ac85365 942do_aexec(SV *really, register SV **mark, register SV **sp)
a687059c 943{
a687059c 944 register char **a;
a687059c
LW
945 char *tmps;
946
79072805 947 if (sp > mark) {
11343788 948 dTHR;
79072805 949 New(401,Argv, sp - mark + 1, char*);
bee1dbe2 950 a = Argv;
79072805
LW
951 while (++mark <= sp) {
952 if (*mark)
463ee0b2 953 *a++ = SvPVx(*mark, na);
a687059c
LW
954 else
955 *a++ = "";
956 }
957 *a = Nullch;
bee1dbe2 958 if (*Argv[0] != '/') /* will execvp use PATH? */
79072805 959 TAINT_ENV(); /* testing IFS here is overkill, probably */
463ee0b2 960 if (really && *(tmps = SvPV(really, na)))
3028581b 961 PerlProc_execvp(tmps,Argv);
a687059c 962 else
3028581b 963 PerlProc_execvp(Argv[0],Argv);
a0d0e21e
LW
964 if (dowarn)
965 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
a687059c 966 }
bee1dbe2 967 do_execfree();
a687059c
LW
968 return FALSE;
969}
970
fe14fcc3 971void
8ac85365 972do_execfree(void)
ff8e2863
LW
973{
974 if (Argv) {
975 Safefree(Argv);
976 Argv = Null(char **);
977 }
978 if (Cmd) {
979 Safefree(Cmd);
980 Cmd = Nullch;
981 }
982}
983
39e571d4 984#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
760ac839 985
a687059c 986bool
8ac85365 987do_exec(char *cmd)
a687059c
LW
988{
989 register char **a;
990 register char *s;
a687059c
LW
991 char flags[10];
992
748a9306
LW
993 while (*cmd && isSPACE(*cmd))
994 cmd++;
995
a687059c
LW
996 /* save an extra exec if possible */
997
bf38876a
LW
998#ifdef CSH
999 if (strnEQ(cmd,cshname,cshlen) && strnEQ(cmd+cshlen," -c",3)) {
a687059c 1000 strcpy(flags,"-c");
bf38876a 1001 s = cmd+cshlen+3;
a687059c
LW
1002 if (*s == 'f') {
1003 s++;
1004 strcat(flags,"f");
1005 }
1006 if (*s == ' ')
1007 s++;
1008 if (*s++ == '\'') {
1009 char *ncmd = s;
1010
1011 while (*s)
1012 s++;
1013 if (s[-1] == '\n')
1014 *--s = '\0';
1015 if (s[-1] == '\'') {
1016 *--s = '\0';
3028581b 1017 PerlProc_execl(cshname,"csh", flags,ncmd,(char*)0);
a687059c
LW
1018 *s = '\'';
1019 return FALSE;
1020 }
1021 }
1022 }
bf38876a 1023#endif /* CSH */
a687059c
LW
1024
1025 /* see if there are shell metacharacters in it */
1026
748a9306
LW
1027 if (*cmd == '.' && isSPACE(cmd[1]))
1028 goto doshell;
1029
1030 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1031 goto doshell;
1032
99b89507 1033 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
63f2c1e1
LW
1034 if (*s == '=')
1035 goto doshell;
748a9306 1036
a687059c 1037 for (s = cmd; *s; s++) {
93a17b20 1038 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1039 if (*s == '\n' && !s[1]) {
1040 *s = '\0';
1041 break;
1042 }
1043 doshell:
3028581b 1044 PerlProc_execl(sh_path, "sh", "-c", cmd, (char*)0);
a687059c
LW
1045 return FALSE;
1046 }
1047 }
748a9306 1048
ff8e2863 1049 New(402,Argv, (s - cmd) / 2 + 2, char*);
a0d0e21e 1050 Cmd = savepvn(cmd, s-cmd);
ff8e2863
LW
1051 a = Argv;
1052 for (s = Cmd; *s;) {
99b89507 1053 while (*s && isSPACE(*s)) s++;
a687059c
LW
1054 if (*s)
1055 *(a++) = s;
99b89507 1056 while (*s && !isSPACE(*s)) s++;
a687059c
LW
1057 if (*s)
1058 *s++ = '\0';
1059 }
1060 *a = Nullch;
ff8e2863 1061 if (Argv[0]) {
3028581b 1062 PerlProc_execvp(Argv[0],Argv);
b1248f16 1063 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1064 do_execfree();
a687059c 1065 goto doshell;
b1248f16 1066 }
a0d0e21e
LW
1067 if (dowarn)
1068 warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
a687059c 1069 }
ff8e2863 1070 do_execfree();
a687059c
LW
1071 return FALSE;
1072}
1073
6890e559 1074#endif /* OS2 || WIN32 */
760ac839 1075
79072805 1076I32
8ac85365 1077apply(I32 type, register SV **mark, register SV **sp)
a687059c 1078{
11343788 1079 dTHR;
79072805
LW
1080 register I32 val;
1081 register I32 val2;
1082 register I32 tot = 0;
20408e3c 1083 char *what;
a687059c 1084 char *s;
79072805 1085 SV **oldmark = mark;
a687059c 1086
20408e3c
GS
1087#define APPLY_TAINT_PROPER() \
1088 if (!(tainting && tainted)) {} else { goto taint_proper; }
1089
1090 /* This is a first heuristic; it doesn't catch tainting magic. */
463ee0b2
LW
1091 if (tainting) {
1092 while (++mark <= sp) {
bbce6d69
PP
1093 if (SvTAINTED(*mark)) {
1094 TAINT;
1095 break;
1096 }
463ee0b2
LW
1097 }
1098 mark = oldmark;
1099 }
a687059c 1100 switch (type) {
79072805 1101 case OP_CHMOD:
20408e3c
GS
1102 what = "chmod";
1103 APPLY_TAINT_PROPER();
79072805 1104 if (++mark <= sp) {
463ee0b2 1105 val = SvIVx(*mark);
20408e3c
GS
1106 APPLY_TAINT_PROPER();
1107 tot = sp - mark;
79072805 1108 while (++mark <= sp) {
20408e3c
GS
1109 char *name = SvPVx(*mark, na);
1110 APPLY_TAINT_PROPER();
1111 if (PerlLIO_chmod(name, val))
a687059c
LW
1112 tot--;
1113 }
1114 }
1115 break;
fe14fcc3 1116#ifdef HAS_CHOWN
79072805 1117 case OP_CHOWN:
20408e3c
GS
1118 what = "chown";
1119 APPLY_TAINT_PROPER();
79072805 1120 if (sp - mark > 2) {
463ee0b2
LW
1121 val = SvIVx(*++mark);
1122 val2 = SvIVx(*++mark);
20408e3c 1123 APPLY_TAINT_PROPER();
a0d0e21e 1124 tot = sp - mark;
79072805 1125 while (++mark <= sp) {
20408e3c
GS
1126 char *name = SvPVx(*mark, na);
1127 APPLY_TAINT_PROPER();
1128 if (chown(name, val, val2))
a687059c
LW
1129 tot--;
1130 }
1131 }
1132 break;
b1248f16 1133#endif
dd64f1c3
AD
1134/*
1135XXX Should we make lchown() directly available from perl?
1136For now, we'll let Configure test for HAS_LCHOWN, but do
1137nothing in the core.
1138 --AD 5/1998
1139*/
fe14fcc3 1140#ifdef HAS_KILL
79072805 1141 case OP_KILL:
20408e3c
GS
1142 what = "kill";
1143 APPLY_TAINT_PROPER();
55497cff
PP
1144 if (mark == sp)
1145 break;
463ee0b2 1146 s = SvPVx(*++mark, na);
79072805
LW
1147 if (isUPPER(*s)) {
1148 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1149 s += 3;
1150 if (!(val = whichsig(s)))
463ee0b2 1151 croak("Unrecognized signal name \"%s\"",s);
79072805
LW
1152 }
1153 else
463ee0b2 1154 val = SvIVx(*mark);
20408e3c
GS
1155 APPLY_TAINT_PROPER();
1156 tot = sp - mark;
3595fcef
PP
1157#ifdef VMS
1158 /* kill() doesn't do process groups (job trees?) under VMS */
1159 if (val < 0) val = -val;
1160 if (val == SIGKILL) {
1161# include <starlet.h>
1162 /* Use native sys$delprc() to insure that target process is
1163 * deleted; supervisor-mode images don't pay attention to
1164 * CRTL's emulation of Unix-style signals and kill()
1165 */
1166 while (++mark <= sp) {
1167 I32 proc = SvIVx(*mark);
1168 register unsigned long int __vmssts;
20408e3c 1169 APPLY_TAINT_PROPER();
3595fcef
PP
1170 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1171 tot--;
1172 switch (__vmssts) {
1173 case SS$_NONEXPR:
1174 case SS$_NOSUCHNODE:
1175 SETERRNO(ESRCH,__vmssts);
1176 break;
1177 case SS$_NOPRIV:
1178 SETERRNO(EPERM,__vmssts);
1179 break;
1180 default:
1181 SETERRNO(EVMSERR,__vmssts);
1182 }
1183 }
1184 }
1185 break;
1186 }
1187#endif
79072805
LW
1188 if (val < 0) {
1189 val = -val;
1190 while (++mark <= sp) {
463ee0b2 1191 I32 proc = SvIVx(*mark);
20408e3c 1192 APPLY_TAINT_PROPER();
fe14fcc3 1193#ifdef HAS_KILLPG
3028581b 1194 if (PerlProc_killpg(proc,val)) /* BSD */
a687059c 1195#else
3028581b 1196 if (PerlProc_kill(-proc,val)) /* SYSV */
a687059c 1197#endif
79072805 1198 tot--;
a687059c 1199 }
79072805
LW
1200 }
1201 else {
1202 while (++mark <= sp) {
20408e3c
GS
1203 I32 proc = SvIVx(*mark);
1204 APPLY_TAINT_PROPER();
1205 if (PerlProc_kill(proc, val))
79072805 1206 tot--;
a687059c
LW
1207 }
1208 }
1209 break;
b1248f16 1210#endif
79072805 1211 case OP_UNLINK:
20408e3c
GS
1212 what = "unlink";
1213 APPLY_TAINT_PROPER();
79072805
LW
1214 tot = sp - mark;
1215 while (++mark <= sp) {
463ee0b2 1216 s = SvPVx(*mark, na);
20408e3c 1217 APPLY_TAINT_PROPER();
a687059c
LW
1218 if (euid || unsafe) {
1219 if (UNLINK(s))
1220 tot--;
1221 }
1222 else { /* don't let root wipe out directories without -U */
fe14fcc3 1223#ifdef HAS_LSTAT
3028581b 1224 if (PerlLIO_lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
a687059c 1225#else
3028581b 1226 if (PerlLIO_stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
a687059c 1227#endif
a687059c
LW
1228 tot--;
1229 else {
1230 if (UNLINK(s))
1231 tot--;
1232 }
1233 }
1234 }
1235 break;
a0d0e21e 1236#ifdef HAS_UTIME
79072805 1237 case OP_UTIME:
20408e3c
GS
1238 what = "utime";
1239 APPLY_TAINT_PROPER();
79072805 1240 if (sp - mark > 2) {
748a9306 1241#if defined(I_UTIME) || defined(VMS)
663a0e37
LW
1242 struct utimbuf utbuf;
1243#else
a687059c 1244 struct {
663a0e37
LW
1245 long actime;
1246 long modtime;
a687059c 1247 } utbuf;
663a0e37 1248#endif
a687059c 1249
afd9f252 1250 Zero(&utbuf, sizeof utbuf, char);
517844ec
PP
1251#ifdef BIG_TIME
1252 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1253 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
1254#else
463ee0b2
LW
1255 utbuf.actime = SvIVx(*++mark); /* time accessed */
1256 utbuf.modtime = SvIVx(*++mark); /* time modified */
517844ec 1257#endif
20408e3c 1258 APPLY_TAINT_PROPER();
79072805
LW
1259 tot = sp - mark;
1260 while (++mark <= sp) {
20408e3c
GS
1261 char *name = SvPVx(*mark, na);
1262 APPLY_TAINT_PROPER();
1263 if (PerlLIO_utime(name, &utbuf))
a687059c
LW
1264 tot--;
1265 }
a687059c
LW
1266 }
1267 else
79072805 1268 tot = 0;
a687059c 1269 break;
a0d0e21e 1270#endif
a687059c
LW
1271 }
1272 return tot;
20408e3c
GS
1273
1274 taint_proper:
1275 TAINT_PROPER(what);
1276 return 0; /* this should never happen */
1277
1278#undef APPLY_TAINT_PROPER
a687059c
LW
1279}
1280
1281/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1282#ifndef VMS /* VMS' cando is in vms.c */
79072805 1283I32
8ac85365 1284cando(I32 bit, I32 effective, register struct stat *statbufp)
a687059c 1285{
bee1dbe2 1286#ifdef DOSISH
fe14fcc3
LW
1287 /* [Comments and code from Len Reed]
1288 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1289 * to write-protected files. The execute permission bit is set
1290 * by the Miscrosoft C library stat() function for the following:
1291 * .exe files
1292 * .com files
1293 * .bat files
1294 * directories
1295 * All files and directories are readable.
1296 * Directories and special files, e.g. "CON", cannot be
1297 * write-protected.
1298 * [Comment by Tom Dinger -- a directory can have the write-protect
1299 * bit set in the file system, but DOS permits changes to
1300 * the directory anyway. In addition, all bets are off
1301 * here for networked software, such as Novell and
1302 * Sun's PC-NFS.]
1303 */
1304
bee1dbe2
LW
1305 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1306 * too so it will actually look into the files for magic numbers
1307 */
fe14fcc3
LW
1308 return (bit & statbufp->st_mode) ? TRUE : FALSE;
1309
55497cff 1310#else /* ! DOSISH */
a687059c 1311 if ((effective ? euid : uid) == 0) { /* root is special */
c623bd54
LW
1312 if (bit == S_IXUSR) {
1313 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1314 return TRUE;
1315 }
1316 else
1317 return TRUE; /* root reads and writes anything */
1318 return FALSE;
1319 }
1320 if (statbufp->st_uid == (effective ? euid : uid) ) {
1321 if (statbufp->st_mode & bit)
1322 return TRUE; /* ok as "user" */
1323 }
79072805 1324 else if (ingroup((I32)statbufp->st_gid,effective)) {
a687059c
LW
1325 if (statbufp->st_mode & bit >> 3)
1326 return TRUE; /* ok as "group" */
1327 }
1328 else if (statbufp->st_mode & bit >> 6)
1329 return TRUE; /* ok as "other" */
1330 return FALSE;
55497cff 1331#endif /* ! DOSISH */
a687059c 1332}
a0d0e21e 1333#endif /* ! VMS */
a687059c 1334
79072805 1335I32
8ac85365 1336ingroup(I32 testgid, I32 effective)
a687059c
LW
1337{
1338 if (testgid == (effective ? egid : gid))
1339 return TRUE;
fe14fcc3 1340#ifdef HAS_GETGROUPS
a687059c
LW
1341#ifndef NGROUPS
1342#define NGROUPS 32
1343#endif
1344 {
a0d0e21e 1345 Groups_t gary[NGROUPS];
79072805 1346 I32 anum;
a687059c
LW
1347
1348 anum = getgroups(NGROUPS,gary);
1349 while (--anum >= 0)
1350 if (gary[anum] == testgid)
1351 return TRUE;
1352 }
1353#endif
1354 return FALSE;
1355}
c2ab57d4 1356
fe14fcc3 1357#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1358
79072805 1359I32
8ac85365 1360do_ipcget(I32 optype, SV **mark, SV **sp)
c2ab57d4 1361{
11343788 1362 dTHR;
c2ab57d4 1363 key_t key;
79072805 1364 I32 n, flags;
c2ab57d4 1365
463ee0b2
LW
1366 key = (key_t)SvNVx(*++mark);
1367 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1368 flags = SvIVx(*++mark);
748a9306 1369 SETERRNO(0,0);
c2ab57d4
LW
1370 switch (optype)
1371 {
fe14fcc3 1372#ifdef HAS_MSG
79072805 1373 case OP_MSGGET:
c2ab57d4 1374 return msgget(key, flags);
e5d73d77 1375#endif
fe14fcc3 1376#ifdef HAS_SEM
79072805 1377 case OP_SEMGET:
c2ab57d4 1378 return semget(key, n, flags);
e5d73d77 1379#endif
fe14fcc3 1380#ifdef HAS_SHM
79072805 1381 case OP_SHMGET:
c2ab57d4 1382 return shmget(key, n, flags);
e5d73d77 1383#endif
fe14fcc3 1384#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1385 default:
c07a80fd 1386 croak("%s not implemented", op_desc[optype]);
e5d73d77 1387#endif
c2ab57d4
LW
1388 }
1389 return -1; /* should never happen */
1390}
1391
79072805 1392I32
8ac85365 1393do_ipcctl(I32 optype, SV **mark, SV **sp)
c2ab57d4 1394{
11343788 1395 dTHR;
79072805 1396 SV *astr;
c2ab57d4 1397 char *a;
a0d0e21e
LW
1398 I32 id, n, cmd, infosize, getinfo;
1399 I32 ret = -1;
c2ab57d4 1400
463ee0b2
LW
1401 id = SvIVx(*++mark);
1402 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1403 cmd = SvIVx(*++mark);
79072805 1404 astr = *++mark;
c2ab57d4
LW
1405 infosize = 0;
1406 getinfo = (cmd == IPC_STAT);
1407
1408 switch (optype)
1409 {
fe14fcc3 1410#ifdef HAS_MSG
79072805 1411 case OP_MSGCTL:
c2ab57d4
LW
1412 if (cmd == IPC_STAT || cmd == IPC_SET)
1413 infosize = sizeof(struct msqid_ds);
1414 break;
e5d73d77 1415#endif
fe14fcc3 1416#ifdef HAS_SHM
79072805 1417 case OP_SHMCTL:
c2ab57d4
LW
1418 if (cmd == IPC_STAT || cmd == IPC_SET)
1419 infosize = sizeof(struct shmid_ds);
1420 break;
e5d73d77 1421#endif
fe14fcc3 1422#ifdef HAS_SEM
79072805 1423 case OP_SEMCTL:
c2ab57d4
LW
1424 if (cmd == IPC_STAT || cmd == IPC_SET)
1425 infosize = sizeof(struct semid_ds);
1426 else if (cmd == GETALL || cmd == SETALL)
1427 {
8e591e46 1428 struct semid_ds semds;
bd89102f
AD
1429 union semun semun;
1430
84902520 1431 semun.buf = &semds;
c2ab57d4 1432 getinfo = (cmd == GETALL);
6e21c824
LW
1433 infosize = semds.sem_nsems * sizeof(short);
1434 /* "short" is technically wrong but much more portable
1435 than guessing about u_?short(_t)? */
c2ab57d4
LW
1436 }
1437 break;
e5d73d77 1438#endif
fe14fcc3 1439#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1440 default:
c07a80fd 1441 croak("%s not implemented", op_desc[optype]);
e5d73d77 1442#endif
c2ab57d4
LW
1443 }
1444
1445 if (infosize)
1446 {
a0d0e21e 1447 STRLEN len;
c2ab57d4
LW
1448 if (getinfo)
1449 {
a0d0e21e
LW
1450 SvPV_force(astr, len);
1451 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
1452 }
1453 else
1454 {
463ee0b2
LW
1455 a = SvPV(astr, len);
1456 if (len != infosize)
9607fc9c
PP
1457 croak("Bad arg length for %s, is %lu, should be %ld",
1458 op_desc[optype], (unsigned long)len, (long)infosize);
c2ab57d4
LW
1459 }
1460 }
1461 else
1462 {
c030ccd9 1463 IV i = SvIV(astr);
c2ab57d4
LW
1464 a = (char *)i; /* ouch */
1465 }
748a9306 1466 SETERRNO(0,0);
c2ab57d4
LW
1467 switch (optype)
1468 {
fe14fcc3 1469#ifdef HAS_MSG
79072805 1470 case OP_MSGCTL:
bee1dbe2 1471 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 1472 break;
e5d73d77 1473#endif
fe14fcc3 1474#ifdef HAS_SEM
bd89102f
AD
1475 case OP_SEMCTL: {
1476 union semun unsemds;
1477
1478 unsemds.buf = (struct semid_ds *)a;
1479 ret = Semctl(id, n, cmd, unsemds);
1480 }
c2ab57d4 1481 break;
e5d73d77 1482#endif
fe14fcc3 1483#ifdef HAS_SHM
79072805 1484 case OP_SHMCTL:
bee1dbe2 1485 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 1486 break;
e5d73d77 1487#endif
c2ab57d4
LW
1488 }
1489 if (getinfo && ret >= 0) {
79072805
LW
1490 SvCUR_set(astr, infosize);
1491 *SvEND(astr) = '\0';
a0d0e21e 1492 SvSETMAGIC(astr);
c2ab57d4
LW
1493 }
1494 return ret;
1495}
1496
79072805 1497I32
8ac85365 1498do_msgsnd(SV **mark, SV **sp)
c2ab57d4 1499{
fe14fcc3 1500#ifdef HAS_MSG
11343788 1501 dTHR;
79072805 1502 SV *mstr;
c2ab57d4 1503 char *mbuf;
79072805 1504 I32 id, msize, flags;
463ee0b2 1505 STRLEN len;
c2ab57d4 1506
463ee0b2 1507 id = SvIVx(*++mark);
79072805 1508 mstr = *++mark;
463ee0b2
LW
1509 flags = SvIVx(*++mark);
1510 mbuf = SvPV(mstr, len);
1511 if ((msize = len - sizeof(long)) < 0)
1512 croak("Arg too short for msgsnd");
748a9306 1513 SETERRNO(0,0);
bee1dbe2 1514 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 1515#else
463ee0b2 1516 croak("msgsnd not implemented");
e5d73d77 1517#endif
c2ab57d4
LW
1518}
1519
79072805 1520I32
8ac85365 1521do_msgrcv(SV **mark, SV **sp)
c2ab57d4 1522{
fe14fcc3 1523#ifdef HAS_MSG
11343788 1524 dTHR;
79072805 1525 SV *mstr;
c2ab57d4
LW
1526 char *mbuf;
1527 long mtype;
79072805 1528 I32 id, msize, flags, ret;
463ee0b2 1529 STRLEN len;
79072805 1530
463ee0b2 1531 id = SvIVx(*++mark);
79072805 1532 mstr = *++mark;
463ee0b2
LW
1533 msize = SvIVx(*++mark);
1534 mtype = (long)SvIVx(*++mark);
1535 flags = SvIVx(*++mark);
ed6116ce
LW
1536 if (SvTHINKFIRST(mstr)) {
1537 if (SvREADONLY(mstr))
1538 croak("Can't msgrcv to readonly var");
1539 if (SvROK(mstr))
1540 sv_unref(mstr);
1541 }
a0d0e21e
LW
1542 SvPV_force(mstr, len);
1543 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
1544
748a9306 1545 SETERRNO(0,0);
bee1dbe2 1546 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 1547 if (ret >= 0) {
79072805
LW
1548 SvCUR_set(mstr, sizeof(long)+ret);
1549 *SvEND(mstr) = '\0';
c2ab57d4
LW
1550 }
1551 return ret;
e5d73d77 1552#else
463ee0b2 1553 croak("msgrcv not implemented");
e5d73d77 1554#endif
c2ab57d4
LW
1555}
1556
79072805 1557I32
8ac85365 1558do_semop(SV **mark, SV **sp)
c2ab57d4 1559{
fe14fcc3 1560#ifdef HAS_SEM
11343788 1561 dTHR;
79072805 1562 SV *opstr;
c2ab57d4 1563 char *opbuf;
463ee0b2
LW
1564 I32 id;
1565 STRLEN opsize;
c2ab57d4 1566
463ee0b2 1567 id = SvIVx(*++mark);
79072805 1568 opstr = *++mark;
463ee0b2 1569 opbuf = SvPV(opstr, opsize);
c2ab57d4
LW
1570 if (opsize < sizeof(struct sembuf)
1571 || (opsize % sizeof(struct sembuf)) != 0) {
748a9306 1572 SETERRNO(EINVAL,LIB$_INVARG);
c2ab57d4
LW
1573 return -1;
1574 }
748a9306 1575 SETERRNO(0,0);
6e21c824 1576 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
e5d73d77 1577#else
463ee0b2 1578 croak("semop not implemented");
e5d73d77 1579#endif
c2ab57d4
LW
1580}
1581
79072805 1582I32
8ac85365 1583do_shmio(I32 optype, SV **mark, SV **sp)
c2ab57d4 1584{
fe14fcc3 1585#ifdef HAS_SHM
11343788 1586 dTHR;
79072805 1587 SV *mstr;
c2ab57d4 1588 char *mbuf, *shm;
79072805 1589 I32 id, mpos, msize;
463ee0b2 1590 STRLEN len;
c2ab57d4 1591 struct shmid_ds shmds;
c2ab57d4 1592
463ee0b2 1593 id = SvIVx(*++mark);
79072805 1594 mstr = *++mark;
463ee0b2
LW
1595 mpos = SvIVx(*++mark);
1596 msize = SvIVx(*++mark);
748a9306 1597 SETERRNO(0,0);
c2ab57d4
LW
1598 if (shmctl(id, IPC_STAT, &shmds) == -1)
1599 return -1;
1600 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
748a9306 1601 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
1602 return -1;
1603 }
8ac85365 1604 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
1605 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1606 return -1;
79072805 1607 if (optype == OP_SHMREAD) {
a0d0e21e
LW
1608 SvPV_force(mstr, len);
1609 mbuf = SvGROW(mstr, msize+1);
1610
bee1dbe2 1611 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
1612 SvCUR_set(mstr, msize);
1613 *SvEND(mstr) = '\0';
a0d0e21e 1614 SvSETMAGIC(mstr);
c2ab57d4
LW
1615 }
1616 else {
79072805 1617 I32 n;
c2ab57d4 1618
a0d0e21e 1619 mbuf = SvPV(mstr, len);
463ee0b2 1620 if ((n = len) > msize)
c2ab57d4 1621 n = msize;
bee1dbe2 1622 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 1623 if (n < msize)
bee1dbe2 1624 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
1625 }
1626 return shmdt(shm);
e5d73d77 1627#else
463ee0b2 1628 croak("shm I/O not implemented");
e5d73d77 1629#endif
c2ab57d4
LW
1630}
1631
fe14fcc3 1632#endif /* SYSV IPC */
4e35701f 1633