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