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