This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
clean up some stray "global" symbols
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
a0d0e21e
LW		 4 *
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.
7 *
8 */
9
10/*
11 * But only a short way ahead its floor and the walls on either side were
12 * cloven by a great fissure, out of which the red glare came, now leaping
13 * up, now dying down into darkness; and all the while far below there was
14 * a rumour and a trouble as of great engines throbbing and labouring.
15 */
16
17#include "EXTERN.h"
18#include "perl.h"
19
f1066039
JH		 20#ifdef I_SHADOW
21/* Shadow password support for solaris - pdo@cs.umd.edu
22 * Not just Solaris: at least HP-UX, IRIX, Linux.
23 * the API is from SysV. --jhi */
8c0bfa08
PB		 24#include <shadow.h>
25#endif
26
76c32331 27/* XXX If this causes problems, set i_unistd=undef in the hint file. */
28#ifdef I_UNISTD
29# include <unistd.h>
30#endif
31
8ac85365
NIS		 32#ifdef HAS_SYSCALL
33#ifdef __cplusplus
34extern "C" int syscall(unsigned long,...);
35#endif
36#endif
37
76c32331 38#ifdef I_SYS_WAIT
39# include <sys/wait.h>
40#endif
41
42#ifdef I_SYS_RESOURCE
43# include <sys/resource.h>
16d20bd9 44#endif
a0d0e21e
LW		 45
46#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
47# include <sys/socket.h>
3fd537d4
JH		 48# ifdef I_NETDB
49# include <netdb.h>
50# endif
a0d0e21e
LW		 51# ifndef ENOTSOCK
52# ifdef I_NET_ERRNO
53# include <net/errno.h>
54# endif
55# endif
56#endif
57
58#ifdef HAS_SELECT
59#ifdef I_SYS_SELECT
a0d0e21e
LW		 60#include <sys/select.h>
61#endif
62#endif
a0d0e21e 63
dc45a647
MB		 64/* XXX Configure test needed.
65 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 66 applications, see "extern int errno in perl.h". Creating such
67 a test requires taking into account the differences between
68 compiling multithreaded and singlethreaded ($ccflags et al).
69 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647
MB		 70*/
71#if defined(HOST_NOT_FOUND) && !defined(h_errno)
a0d0e21e
LW		 72extern int h_errno;
73#endif
74
75#ifdef HAS_PASSWD
76# ifdef I_PWD
77# include <pwd.h>
78# else
20ce7b12
GS		 79 struct passwd *getpwnam (char *);
80 struct passwd *getpwuid (Uid_t);
a0d0e21e 81# endif
28e8609d 82# ifdef HAS_GETPWENT
20ce7b12 83 struct passwd *getpwent (void);
28e8609d 84# endif
a0d0e21e
LW		 85#endif
86
87#ifdef HAS_GROUP
88# ifdef I_GRP
89# include <grp.h>
90# else
20ce7b12
GS		 91 struct group *getgrnam (char *);
92 struct group *getgrgid (Gid_t);
a0d0e21e 93# endif
28e8609d 94# ifdef HAS_GETGRENT
20ce7b12 95 struct group *getgrent (void);
28e8609d 96# endif
a0d0e21e
LW		 97#endif
98
99#ifdef I_UTIME
3730b96e 100# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 101# include <sys/utime.h>
102# else
103# include <utime.h>
104# endif
a0d0e21e
LW		 105#endif
106#ifdef I_FCNTL
107#include <fcntl.h>
108#endif
109#ifdef I_SYS_FILE
110#include <sys/file.h>
111#endif
112
54310121 113/* Put this after #includes because fork and vfork prototypes may conflict. */
114#ifndef HAS_VFORK
115# define vfork fork
116#endif
117
d574b85e
CS		 118/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
119#ifndef Sock_size_t
137443ea 120# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 121# define Sock_size_t Size_t
122# else
123# define Sock_size_t int
124# endif
54310121 125#endif
126
a0d0e21e 127#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
20ce7b12 128static int dooneliner (char *cmd, char *filename);
a0d0e21e 129#endif
cbdc8872 130
131#ifdef HAS_CHSIZE
cd52b7b2 132# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
133# undef my_chsize
134# endif
6ad3d225 135# define my_chsize PerlLIO_chsize
cbdc8872 136#endif
137
ff68c719 138#ifdef HAS_FLOCK
139# define FLOCK flock
140#else /* no flock() */
141
36477c24 142 /* fcntl.h might not have been included, even if it exists, because
143 the current Configure only sets I_FCNTL if it's needed to pick up
144 the *_OK constants. Make sure it has been included before testing
145 the fcntl() locking constants. */
146# if defined(HAS_FCNTL) && !defined(I_FCNTL)
147# include <fcntl.h>
148# endif
149
ff68c719 150# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
151# define FLOCK fcntl_emulate_flock
152# define FCNTL_EMULATE_FLOCK
153# else /* no flock() or fcntl(F_SETLK,...) */
154# ifdef HAS_LOCKF
155# define FLOCK lockf_emulate_flock
156# define LOCKF_EMULATE_FLOCK
157# endif /* lockf */
158# endif /* no flock() or fcntl(F_SETLK,...) */
159
160# ifdef FLOCK
20ce7b12 161 static int FLOCK (int, int);
ff68c719 162
163 /*
164 * These are the flock() constants. Since this sytems doesn't have
165 * flock(), the values of the constants are probably not available.
166 */
167# ifndef LOCK_SH
168# define LOCK_SH 1
169# endif
170# ifndef LOCK_EX
171# define LOCK_EX 2
172# endif
173# ifndef LOCK_NB
174# define LOCK_NB 4
175# endif
176# ifndef LOCK_UN
177# define LOCK_UN 8
178# endif
179# endif /* emulating flock() */
180
181#endif /* no flock() */
55497cff 182
85ab1d1d
JH		 183#define ZBTLEN 10
184static char zero_but_true[ZBTLEN + 1] = "0 but true";
185
5ff3f7a4
GS		 186#if defined(I_SYS_ACCESS) && !defined(R_OK)
187# include <sys/access.h>
188#endif
189
190#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
191#undef PERL_EFF_ACCESS_W_OK
192#undef PERL_EFF_ACCESS_X_OK
193
194/* F_OK unused: if stat() cannot find it... */
195
196#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 197 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 198# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
199# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
200# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
201#endif
202
203#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS		 204# if defined(I_SYS_SECURITY)
205# include <sys/security.h>
206# endif
c955f117
JH		 207 /* XXX Configure test needed for eaccess */
208# ifdef ACC_SELF
209 /* HP SecureWare */
210# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
211# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
212# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
213# else
214 /* SCO */
215# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
216# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
217# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
218# endif
5ff3f7a4
GS		 219#endif
220
221#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 222 /* AIX */
5ff3f7a4
GS		 223# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
224# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
225# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
226#endif
227
327c3667
GS		 228#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 231/* The Hard Way. */
327c3667 232STATIC int
ba106d47
GS		 233emulate_eaccess (const char* path, int mode)
234{
5ff3f7a4
GS		 235 Uid_t ruid = getuid();
236 Uid_t euid = geteuid();
237 Gid_t rgid = getgid();
238 Gid_t egid = getegid();
239 int res;
240
241 MUTEX_LOCK(&PL_cred_mutex);
242#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
85ab1d1d 243 croak("switching effective uid is not implemented");
5ff3f7a4
GS		 244#else
245#ifdef HAS_SETREUID
246 if (setreuid(euid, ruid))
247#else
248#ifdef HAS_SETRESUID
249 if (setresuid(euid, ruid, (Uid_t)-1))
250#endif
251#endif
85ab1d1d 252 croak("entering effective uid failed");
5ff3f7a4
GS		 253#endif
254
255#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
85ab1d1d 256 croak("switching effective gid is not implemented");
5ff3f7a4
GS		 257#else
258#ifdef HAS_SETREGID
259 if (setregid(egid, rgid))
260#else
261#ifdef HAS_SETRESGID
262 if (setresgid(egid, rgid, (Gid_t)-1))
263#endif
264#endif
85ab1d1d 265 croak("entering effective gid failed");
5ff3f7a4
GS		 266#endif
267
268 res = access(path, mode);
269
270#ifdef HAS_SETREUID
271 if (setreuid(ruid, euid))
272#else
273#ifdef HAS_SETRESUID
274 if (setresuid(ruid, euid, (Uid_t)-1))
275#endif
276#endif
85ab1d1d 277 croak("leaving effective uid failed");
5ff3f7a4
GS		 278
279#ifdef HAS_SETREGID
280 if (setregid(rgid, egid))
281#else
282#ifdef HAS_SETRESGID
283 if (setresgid(rgid, egid, (Gid_t)-1))
284#endif
285#endif
85ab1d1d 286 croak("leaving effective gid failed");
5ff3f7a4
GS		 287 MUTEX_UNLOCK(&PL_cred_mutex);
288
289 return res;
290}
291# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
292# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
293# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
294#endif
295
296#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 297STATIC int
ba106d47
GS		 298emulate_eaccess (const char* path, int mode)
299{
85ab1d1d 300 croak("switching effective uid is not implemented");
5ff3f7a4
GS		 301 /*NOTREACHED*/
302 return -1;
303}
304#endif
305
a0d0e21e
LW		 306PP(pp_backtick)
307{
4e35701f 308 djSP; dTARGET;
760ac839 309 PerlIO *fp;
2d8e6c8d
GS		 310 STRLEN n_a;
311 char *tmps = POPpx;
54310121 312 I32 gimme = GIMME_V;
313
a0d0e21e 314 TAINT_PROPER("``");
6ad3d225 315 fp = PerlProc_popen(tmps, "r");
a0d0e21e 316 if (fp) {
54310121 317 if (gimme == G_VOID) {
96827780
MB		 318 char tmpbuf[256];
319 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 320 /*SUPPRESS 530*/
321 ;
322 }
323 else if (gimme == G_SCALAR) {
aa689395 324 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 325 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
326 /*SUPPRESS 530*/
327 ;
328 XPUSHs(TARG);
aa689395 329 SvTAINTED_on(TARG);
a0d0e21e
LW		 330 }
331 else {
332 SV *sv;
333
334 for (;;) {
8d6dde3e 335 sv = NEWSV(56, 79);
a0d0e21e
LW		 336 if (sv_gets(sv, fp, 0) == Nullch) {
337 SvREFCNT_dec(sv);
338 break;
339 }
340 XPUSHs(sv_2mortal(sv));
341 if (SvLEN(sv) - SvCUR(sv) > 20) {
342 SvLEN_set(sv, SvCUR(sv)+1);
343 Renew(SvPVX(sv), SvLEN(sv), char);
344 }
aa689395 345 SvTAINTED_on(sv);
a0d0e21e
LW		 346 }
347 }
6ad3d225 348 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 349 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 350 }
351 else {
f86702cc 352 STATUS_NATIVE_SET(-1);
54310121 353 if (gimme == G_SCALAR)
a0d0e21e
LW		 354 RETPUSHUNDEF;
355 }
356
357 RETURN;
358}
359
360PP(pp_glob)
361{
362 OP *result;
f5284f61
IZ		 363 tryAMAGICunTARGET(iter, -1);
364
a0d0e21e 365 ENTER;
a0d0e21e 366
c90c0ff4 367#ifndef VMS
3280af22 368 if (PL_tainting) {
7bac28a0 369 /*
370 * The external globbing program may use things we can't control,
371 * so for security reasons we must assume the worst.
372 */
373 TAINT;
22c35a8c 374 taint_proper(PL_no_security, "glob");
7bac28a0 375 }
c90c0ff4 376#endif /* !VMS */
7bac28a0 377
3280af22
NIS		 378 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
379 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 380
3280af22 381 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 382 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 383#ifndef DOSISH
384#ifndef CSH
6b88bc9c 385 *SvPVX(PL_rs) = '\n';
a0d0e21e 386#endif /* !CSH */
55497cff 387#endif /* !DOSISH */
c07a80fd 388
a0d0e21e
LW		 389 result = do_readline();
390 LEAVE;
391 return result;
392}
393
15e52e56 394#if 0 /* XXX never used! */
a0d0e21e
LW		 395PP(pp_indread)
396{
2d8e6c8d
GS		 397 STRLEN n_a;
398 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 399 return do_readline();
400}
15e52e56 401#endif
a0d0e21e
LW		 402
403PP(pp_rcatline)
404{
3280af22 405 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW		 406 return do_readline();
407}
408
409PP(pp_warn)
410{
4e35701f 411 djSP; dMARK;
06bf62c7 412 SV *tmpsv;
a0d0e21e 413 char *tmps;
06bf62c7 414 STRLEN len;
a0d0e21e
LW		 415 if (SP - MARK != 1) {
416 dTARGET;
3280af22 417 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 418 tmpsv = TARG;
a0d0e21e
LW		 419 SP = MARK + 1;
420 }
421 else {
06bf62c7 422 tmpsv = TOPs;
a0d0e21e 423 }
06bf62c7
GS		 424 tmps = SvPV(tmpsv, len);
425 if (!tmps || !len) {
4e6ea2c3
GS		 426 SV *error = ERRSV;
427 (void)SvUPGRADE(error, SVt_PV);
428 if (SvPOK(error) && SvCUR(error))
429 sv_catpv(error, "\t...caught");
06bf62c7
GS		 430 tmpsv = error;
431 tmps = SvPV(tmpsv, len);
a0d0e21e 432 }
06bf62c7
GS		 433 if (!tmps || !len)
434 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
435
436 warn("%_", tmpsv);
a0d0e21e
LW		 437 RETSETYES;
438}
439
440PP(pp_die)
441{
4e35701f 442 djSP; dMARK;
a0d0e21e 443 char *tmps;
06bf62c7
GS		 444 SV *tmpsv;
445 STRLEN len;
446 bool multiarg = 0;
a0d0e21e
LW		 447 if (SP - MARK != 1) {
448 dTARGET;
3280af22 449 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 450 tmpsv = TARG;
451 tmps = SvPV(tmpsv, len);
452 multiarg = 1;
a0d0e21e
LW		 453 SP = MARK + 1;
454 }
455 else {
4e6ea2c3 456 tmpsv = TOPs;
06bf62c7 457 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 458 }
06bf62c7 459 if (!tmps || !len) {
4e6ea2c3
GS		 460 SV *error = ERRSV;
461 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 462 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
463 if (!multiarg)
4e6ea2c3 464 SvSetSV(error,tmpsv);
06bf62c7 465 else if (sv_isobject(error)) {
05423cc9
GS		 466 HV *stash = SvSTASH(SvRV(error));
467 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
468 if (gv) {
3280af22
NIS		 469 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
470 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS		 471 EXTEND(SP, 3);
472 PUSHMARK(SP);
473 PUSHs(error);
474 PUSHs(file);
475 PUSHs(line);
476 PUTBACK;
477 perl_call_sv((SV*)GvCV(gv),
478 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 479 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 480 }
481 }
06bf62c7 482 DIE(Nullch);
4e6ea2c3
GS		 483 }
484 else {
485 if (SvPOK(error) && SvCUR(error))
486 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 487 tmpsv = error;
488 tmps = SvPV(tmpsv, len);
4e6ea2c3 489 }
a0d0e21e 490 }
06bf62c7
GS		 491 if (!tmps || !len)
492 tmpsv = sv_2mortal(newSVpvn("Died", 4));
493
494 DIE("%_", tmpsv);
a0d0e21e
LW		 495}
496
497/* I/O. */
498
499PP(pp_open)
500{
4e35701f 501 djSP; dTARGET;
a0d0e21e
LW		 502 GV *gv;
503 SV *sv;
504 char *tmps;
505 STRLEN len;
4592e6ca 506 MAGIC *mg;
a0d0e21e
LW		 507
508 if (MAXARG > 1)
509 sv = POPs;
5f05dabc 510 if (!isGV(TOPs))
22c35a8c 511 DIE(PL_no_usym, "filehandle");
5f05dabc 512 if (MAXARG <= 1)
513 sv = GvSV(TOPs);
a0d0e21e 514 gv = (GV*)POPs;
5f05dabc 515 if (!isGV(gv))
22c35a8c 516 DIE(PL_no_usym, "filehandle");
36477c24 517 if (GvIOp(gv))
518 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea
NIS		 519
520#if 0 /* no undef means tmpfile() yet */
3eb568f1
NIS		 521 if (sv == &PL_sv_undef) {
522#ifdef PerlIO
523 PerlIO *fp = PerlIO_tmpfile();
524#else
525 PerlIO *fp = tmpfile();
526#endif
527 if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
528 PUSHi( (I32)PL_forkprocess );
529 else
530 RETPUSHUNDEF;
531 RETURN;
532 }
853846ea
NIS		 533#endif /* no undef means tmpfile() yet */
534
4592e6ca
NIS		 535
536 if (mg = SvTIED_mg((SV*)gv, 'q')) {
537 PUSHMARK(SP);
538 XPUSHs(SvTIED_obj((SV*)gv, mg));
539 XPUSHs(sv);
540 PUTBACK;
541 ENTER;
542 perl_call_method("OPEN", G_SCALAR);
543 LEAVE;
544 SPAGAIN;
545 RETURN;
546 }
547
a0d0e21e 548 tmps = SvPV(sv, len);
9d116dd7 549 if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
3280af22
NIS		 550 PUSHi( (I32)PL_forkprocess );
551 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 552 PUSHi(0);
553 else
554 RETPUSHUNDEF;
555 RETURN;
556}
557
558PP(pp_close)
559{
4e35701f 560 djSP;
a0d0e21e 561 GV *gv;
1d603a67 562 MAGIC *mg;
a0d0e21e
LW		 563
564 if (MAXARG == 0)
3280af22 565 gv = PL_defoutgv;
a0d0e21e
LW		 566 else
567 gv = (GV*)POPs;
1d603a67 568
33c27489 569 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 570 PUSHMARK(SP);
33c27489 571 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 572 PUTBACK;
573 ENTER;
574 perl_call_method("CLOSE", G_SCALAR);
575 LEAVE;
576 SPAGAIN;
577 RETURN;
578 }
a0d0e21e 579 EXTEND(SP, 1);
54310121 580 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 581 RETURN;
582}
583
584PP(pp_pipe_op)
585{
4e35701f 586 djSP;
a0d0e21e
LW		 587#ifdef HAS_PIPE
588 GV *rgv;
589 GV *wgv;
590 register IO *rstio;
591 register IO *wstio;
592 int fd[2];
593
594 wgv = (GV*)POPs;
595 rgv = (GV*)POPs;
596
597 if (!rgv || !wgv)
598 goto badexit;
599
4633a7c4 600 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
22c35a8c 601 DIE(PL_no_usym, "filehandle");
a0d0e21e
LW		 602 rstio = GvIOn(rgv);
603 wstio = GvIOn(wgv);
604
605 if (IoIFP(rstio))
606 do_close(rgv, FALSE);
607 if (IoIFP(wstio))
608 do_close(wgv, FALSE);
609
6ad3d225 610 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 611 goto badexit;
612
760ac839
LW		 613 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
614 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 615 IoIFP(wstio) = IoOFP(wstio);
616 IoTYPE(rstio) = '<';
617 IoTYPE(wstio) = '>';
618
619 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 620 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 621 else PerlLIO_close(fd[0]);
760ac839 622 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 623 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 624 goto badexit;
625 }
4771b018
GS		 626#if defined(HAS_FCNTL) && defined(F_SETFD)
627 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
628 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
629#endif
a0d0e21e
LW		 630 RETPUSHYES;
631
632badexit:
633 RETPUSHUNDEF;
634#else
22c35a8c 635 DIE(PL_no_func, "pipe");
a0d0e21e
LW		 636#endif
637}
638
639PP(pp_fileno)
640{
4e35701f 641 djSP; dTARGET;
a0d0e21e
LW		 642 GV *gv;
643 IO *io;
760ac839 644 PerlIO *fp;
4592e6ca
NIS		 645 MAGIC *mg;
646
a0d0e21e
LW		 647 if (MAXARG < 1)
648 RETPUSHUNDEF;
649 gv = (GV*)POPs;
4592e6ca
NIS		 650
651 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
652 PUSHMARK(SP);
653 XPUSHs(SvTIED_obj((SV*)gv, mg));
654 PUTBACK;
655 ENTER;
656 perl_call_method("FILENO", G_SCALAR);
657 LEAVE;
658 SPAGAIN;
659 RETURN;
660 }
661
a0d0e21e
LW		 662 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
663 RETPUSHUNDEF;
760ac839 664 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 665 RETURN;
666}
667
668PP(pp_umask)
669{
4e35701f 670 djSP; dTARGET;
761237fe 671 Mode_t anum;
a0d0e21e
LW		 672
673#ifdef HAS_UMASK
674 if (MAXARG < 1) {
6ad3d225
GS		 675 anum = PerlLIO_umask(0);
676 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 677 }
678 else
6ad3d225 679 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 680 TAINT_PROPER("umask");
681 XPUSHi(anum);
682#else
eec2d3df
GS		 683 /* Only DIE if trying to restrict permissions on `user' (self).
684 * Otherwise it's harmless and more useful to just return undef
685 * since 'group' and 'other' concepts probably don't exist here. */
686 if (MAXARG >= 1 && (POPi & 0700))
687 DIE("umask not implemented");
6b88bc9c 688 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 689#endif
690 RETURN;
691}
692
693PP(pp_binmode)
694{
4e35701f 695 djSP;
a0d0e21e
LW		 696 GV *gv;
697 IO *io;
760ac839 698 PerlIO *fp;
4592e6ca 699 MAGIC *mg;
a0d0e21e
LW		 700
701 if (MAXARG < 1)
702 RETPUSHUNDEF;
703
4592e6ca
NIS		 704 gv = (GV*)POPs;
705
706 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
707 PUSHMARK(SP);
708 XPUSHs(SvTIED_obj((SV*)gv, mg));
709 PUTBACK;
710 ENTER;
711 perl_call_method("BINMODE", G_SCALAR);
712 LEAVE;
713 SPAGAIN;
714 RETURN;
715 }
a0d0e21e
LW		 716
717 EXTEND(SP, 1);
718 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 719 RETPUSHUNDEF;
a0d0e21e 720
491527d0 721 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW		 722 RETPUSHYES;
723 else
724 RETPUSHUNDEF;
a0d0e21e
LW		 725}
726
b8e3bfaf 727
a0d0e21e
LW		 728PP(pp_tie)
729{
4e35701f 730 djSP;
e336de0d 731 dMARK;
a0d0e21e
LW		 732 SV *varsv;
733 HV* stash;
734 GV *gv;
a0d0e21e 735 SV *sv;
3280af22 736 I32 markoff = MARK - PL_stack_base;
a0d0e21e 737 char *methname;
6b05c17a 738 int how = 'P';
e336de0d 739 U32 items;
2d8e6c8d 740 STRLEN n_a;
a0d0e21e 741
e336de0d 742 varsv = *++MARK;
6b05c17a
NIS		 743 switch(SvTYPE(varsv)) {
744 case SVt_PVHV:
745 methname = "TIEHASH";
746 break;
747 case SVt_PVAV:
748 methname = "TIEARRAY";
749 break;
750 case SVt_PVGV:
751 methname = "TIEHANDLE";
752 how = 'q';
753 break;
754 default:
755 methname = "TIESCALAR";
756 how = 'q';
757 break;
758 }
e336de0d
GS		 759 items = SP - MARK++;
760 if (sv_isobject(*MARK)) {
6b05c17a 761 ENTER;
e788e7d3 762 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 763 PUSHMARK(SP);
764 EXTEND(SP,items);
765 while (items--)
766 PUSHs(*MARK++);
767 PUTBACK;
6b05c17a
NIS		 768 perl_call_method(methname, G_SCALAR);
769 }
770 else {
771 /* Not clear why we don't call perl_call_method here too.
772 * perhaps to get different error message ?
773 */
e336de0d 774 stash = gv_stashsv(*MARK, FALSE);
6b05c17a
NIS		 775 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
776 DIE("Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 777 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 778 }
779 ENTER;
e788e7d3 780 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 781 PUSHMARK(SP);
782 EXTEND(SP,items);
783 while (items--)
784 PUSHs(*MARK++);
785 PUTBACK;
6b05c17a
NIS		 786 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
787 }
a0d0e21e
LW		 788 SPAGAIN;
789
790 sv = TOPs;
d3acc0f7 791 POPSTACK;
a0d0e21e 792 if (sv_isobject(sv)) {
33c27489
GS		 793 sv_unmagic(varsv, how);
794 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW		 795 }
796 LEAVE;
3280af22 797 SP = PL_stack_base + markoff;
a0d0e21e
LW		 798 PUSHs(sv);
799 RETURN;
800}
801
802PP(pp_untie)
803{
4e35701f 804 djSP;
33c27489
GS		 805 SV *sv = POPs;
806 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 807
599cee73 808 if (ckWARN(WARN_UNTIE)) {
cbdc8872 809 MAGIC * mg ;
33c27489 810 if (mg = SvTIED_mg(sv, how)) {
cbdc8872 811 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
599cee73
PM		 812 warner(WARN_UNTIE,
813 "untie attempted while %lu inner references still exist",
814 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 815 }
816 }
817
33c27489 818 sv_unmagic(sv, how);
55497cff 819 RETPUSHYES;
a0d0e21e
LW		 820}
821
c07a80fd 822PP(pp_tied)
823{
4e35701f 824 djSP;
33c27489
GS		 825 SV *sv = POPs;
826 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
827 MAGIC *mg;
c07a80fd 828
33c27489
GS		 829 if (mg = SvTIED_mg(sv, how)) {
830 SV *osv = SvTIED_obj(sv, mg);
831 if (osv == mg->mg_obj)
832 osv = sv_mortalcopy(osv);
833 PUSHs(osv);
834 RETURN;
c07a80fd 835 }
c07a80fd 836 RETPUSHUNDEF;
837}
838
a0d0e21e
LW		 839PP(pp_dbmopen)
840{
4e35701f 841 djSP;
a0d0e21e
LW		 842 HV *hv;
843 dPOPPOPssrl;
844 HV* stash;
845 GV *gv;
a0d0e21e
LW		 846 SV *sv;
847
848 hv = (HV*)POPs;
849
3280af22 850 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 851 sv_setpv(sv, "AnyDBM_File");
852 stash = gv_stashsv(sv, FALSE);
8ebc5c01 853 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 854 PUTBACK;
4633a7c4 855 perl_require_pv("AnyDBM_File.pm");
a0d0e21e 856 SPAGAIN;
8ebc5c01 857 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
a0d0e21e
LW		 858 DIE("No dbm on this machine");
859 }
860
57d3b86d 861 ENTER;
924508f0 862 PUSHMARK(SP);
6b05c17a 863
924508f0 864 EXTEND(SP, 5);
a0d0e21e
LW		 865 PUSHs(sv);
866 PUSHs(left);
867 if (SvIV(right))
868 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
869 else
870 PUSHs(sv_2mortal(newSViv(O_RDWR)));
871 PUSHs(right);
57d3b86d 872 PUTBACK;
38a03e6e 873 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 874 SPAGAIN;
875
876 if (!sv_isobject(TOPs)) {
924508f0
GS		 877 SP--;
878 PUSHMARK(SP);
a0d0e21e
LW		 879 PUSHs(sv);
880 PUSHs(left);
881 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
882 PUSHs(right);
a0d0e21e 883 PUTBACK;
38a03e6e 884 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 885 SPAGAIN;
886 }
887
6b05c17a
NIS		 888 if (sv_isobject(TOPs)) {
889 sv_unmagic((SV *) hv, 'P');
a0d0e21e 890 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 891 }
a0d0e21e
LW		 892 LEAVE;
893 RETURN;
894}
895
896PP(pp_dbmclose)
897{
898 return pp_untie(ARGS);
899}
900
901PP(pp_sselect)
902{
4e35701f 903 djSP; dTARGET;
a0d0e21e
LW		 904#ifdef HAS_SELECT
905 register I32 i;
906 register I32 j;
907 register char *s;
908 register SV *sv;
909 double value;
910 I32 maxlen = 0;
911 I32 nfound;
912 struct timeval timebuf;
913 struct timeval *tbuf = &timebuf;
914 I32 growsize;
915 char *fd_sets[4];
2d8e6c8d 916 STRLEN n_a;
a0d0e21e
LW		 917#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
918 I32 masksize;
919 I32 offset;
920 I32 k;
921
922# if BYTEORDER & 0xf0000
923# define ORDERBYTE (0x88888888 - BYTEORDER)
924# else
925# define ORDERBYTE (0x4444 - BYTEORDER)
926# endif
927
928#endif
929
930 SP -= 4;
931 for (i = 1; i <= 3; i++) {
932 if (!SvPOK(SP[i]))
933 continue;
934 j = SvCUR(SP[i]);
935 if (maxlen < j)
936 maxlen = j;
937 }
938
5ff3f7a4 939/* little endians can use vecs directly */
a0d0e21e 940#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 941# if SELECT_MIN_BITS > 1
f2da832e
JH		 942 /* If SELECT_MIN_BITS is greater than one we most probably will want
943 * to align the sizes with SELECT_MIN_BITS/8 because for example
944 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W		 945 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
946 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 947 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 948# else
4633a7c4 949 growsize = sizeof(fd_set);
5ff3f7a4
GS		 950# endif
951# else
952# ifdef NFDBITS
a0d0e21e 953
5ff3f7a4
GS		 954# ifndef NBBY
955# define NBBY 8
956# endif
a0d0e21e
LW		 957
958 masksize = NFDBITS / NBBY;
5ff3f7a4 959# else
a0d0e21e 960 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 961# endif
a0d0e21e
LW		 962 growsize = maxlen + (masksize - (maxlen % masksize));
963 Zero(&fd_sets[0], 4, char*);
964#endif
965
966 sv = SP[4];
967 if (SvOK(sv)) {
968 value = SvNV(sv);
969 if (value < 0.0)
970 value = 0.0;
971 timebuf.tv_sec = (long)value;
972 value -= (double)timebuf.tv_sec;
973 timebuf.tv_usec = (long)(value * 1000000.0);
974 }
975 else
976 tbuf = Null(struct timeval*);
977
978 for (i = 1; i <= 3; i++) {
979 sv = SP[i];
980 if (!SvOK(sv)) {
981 fd_sets[i] = 0;
982 continue;
983 }
984 else if (!SvPOK(sv))
2d8e6c8d 985 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 986 j = SvLEN(sv);
987 if (j < growsize) {
988 Sv_Grow(sv, growsize);
a0d0e21e 989 }
c07a80fd 990 j = SvCUR(sv);
991 s = SvPVX(sv) + j;
992 while (++j <= growsize) {
993 *s++ = '\0';
994 }
995
a0d0e21e
LW		 996#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
997 s = SvPVX(sv);
998 New(403, fd_sets[i], growsize, char);
999 for (offset = 0; offset < growsize; offset += masksize) {
1000 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1001 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1002 }
1003#else
1004 fd_sets[i] = SvPVX(sv);
1005#endif
1006 }
1007
6ad3d225 1008 nfound = PerlSock_select(
a0d0e21e
LW		 1009 maxlen * 8,
1010 (Select_fd_set_t) fd_sets[1],
1011 (Select_fd_set_t) fd_sets[2],
1012 (Select_fd_set_t) fd_sets[3],
1013 tbuf);
1014 for (i = 1; i <= 3; i++) {
1015 if (fd_sets[i]) {
1016 sv = SP[i];
1017#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1018 s = SvPVX(sv);
1019 for (offset = 0; offset < growsize; offset += masksize) {
1020 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1021 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1022 }
1023 Safefree(fd_sets[i]);
1024#endif
1025 SvSETMAGIC(sv);
1026 }
1027 }
1028
1029 PUSHi(nfound);
1030 if (GIMME == G_ARRAY && tbuf) {
1031 value = (double)(timebuf.tv_sec) +
1032 (double)(timebuf.tv_usec) / 1000000.0;
3280af22 1033 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1034 sv_setnv(sv, value);
1035 }
1036 RETURN;
1037#else
1038 DIE("select not implemented");
1039#endif
1040}
1041
4633a7c4 1042void
8ac85365 1043setdefout(GV *gv)
4633a7c4 1044{
11343788 1045 dTHR;
4633a7c4
LW		 1046 if (gv)
1047 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1048 if (PL_defoutgv)
1049 SvREFCNT_dec(PL_defoutgv);
1050 PL_defoutgv = gv;
4633a7c4
LW		 1051}
1052
a0d0e21e
LW		 1053PP(pp_select)
1054{
4e35701f 1055 djSP; dTARGET;
4633a7c4
LW		 1056 GV *newdefout, *egv;
1057 HV *hv;
1058
533c011a 1059 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1060
3280af22 1061 egv = GvEGV(PL_defoutgv);
4633a7c4 1062 if (!egv)
3280af22 1063 egv = PL_defoutgv;
4633a7c4
LW		 1064 hv = GvSTASH(egv);
1065 if (! hv)
3280af22 1066 XPUSHs(&PL_sv_undef);
4633a7c4 1067 else {
cbdc8872 1068 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1069 if (gvp && *gvp == egv) {
3280af22 1070 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc 1071 XPUSHTARG;
1072 }
1073 else {
1074 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1075 }
4633a7c4
LW		 1076 }
1077
1078 if (newdefout) {
ded8aa31
GS		 1079 if (!GvIO(newdefout))
1080 gv_IOadd(newdefout);
4633a7c4
LW		 1081 setdefout(newdefout);
1082 }
1083
a0d0e21e
LW		 1084 RETURN;
1085}
1086
1087PP(pp_getc)
1088{
4e35701f 1089 djSP; dTARGET;
a0d0e21e 1090 GV *gv;
2ae324a7 1091 MAGIC *mg;
a0d0e21e
LW		 1092
1093 if (MAXARG <= 0)
3280af22 1094 gv = PL_stdingv;
a0d0e21e
LW		 1095 else
1096 gv = (GV*)POPs;
1097 if (!gv)
3280af22 1098 gv = PL_argvgv;
2ae324a7 1099
33c27489 1100 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1101 I32 gimme = GIMME_V;
2ae324a7 1102 PUSHMARK(SP);
33c27489 1103 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1104 PUTBACK;
1105 ENTER;
54310121 1106 perl_call_method("GETC", gimme);
2ae324a7 1107 LEAVE;
1108 SPAGAIN;
54310121 1109 if (gimme == G_SCALAR)
1110 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1111 RETURN;
1112 }
9bc64814 1113 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1114 RETPUSHUNDEF;
bbce6d69 1115 TAINT;
a0d0e21e 1116 sv_setpv(TARG, " ");
9bc64814 1117 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1118 PUSHTARG;
1119 RETURN;
1120}
1121
1122PP(pp_read)
1123{
1124 return pp_sysread(ARGS);
1125}
1126
76e3520e 1127STATIC OP *
8ac85365 1128doform(CV *cv, GV *gv, OP *retop)
a0d0e21e 1129{
11343788 1130 dTHR;
c09156bb 1131 register PERL_CONTEXT *cx;
54310121 1132 I32 gimme = GIMME_V;
a0d0e21e
LW		 1133 AV* padlist = CvPADLIST(cv);
1134 SV** svp = AvARRAY(padlist);
1135
1136 ENTER;
1137 SAVETMPS;
1138
1139 push_return(retop);
3280af22 1140 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1141 PUSHFORMAT(cx);
3280af22
NIS		 1142 SAVESPTR(PL_curpad);
1143 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1144
4633a7c4 1145 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1146 return CvSTART(cv);
1147}
1148
1149PP(pp_enterwrite)
1150{
4e35701f 1151 djSP;
a0d0e21e
LW		 1152 register GV *gv;
1153 register IO *io;
1154 GV *fgv;
1155 CV *cv;
1156
1157 if (MAXARG == 0)
3280af22 1158 gv = PL_defoutgv;
a0d0e21e
LW		 1159 else {
1160 gv = (GV*)POPs;
1161 if (!gv)
3280af22 1162 gv = PL_defoutgv;
a0d0e21e
LW		 1163 }
1164 EXTEND(SP, 1);
1165 io = GvIO(gv);
1166 if (!io) {
1167 RETPUSHNO;
1168 }
1169 if (IoFMT_GV(io))
1170 fgv = IoFMT_GV(io);
1171 else
1172 fgv = gv;
1173
1174 cv = GvFORM(fgv);
a0d0e21e
LW		 1175 if (!cv) {
1176 if (fgv) {
748a9306 1177 SV *tmpsv = sv_newmortal();
aac0dd9a 1178 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 1179 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW		 1180 }
1181 DIE("Not a format reference");
1182 }
44a8e56a 1183 if (CvCLONE(cv))
1184 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1185
44a8e56a 1186 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1187 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1188}
1189
1190PP(pp_leavewrite)
1191{
4e35701f 1192 djSP;
a0d0e21e
LW		 1193 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1194 register IO *io = GvIOp(gv);
760ac839
LW		 1195 PerlIO *ofp = IoOFP(io);
1196 PerlIO *fp;
a0d0e21e
LW		 1197 SV **newsp;
1198 I32 gimme;
c09156bb 1199 register PERL_CONTEXT *cx;
a0d0e21e 1200
760ac839 1201 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1202 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1203 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1204 PL_formtarget != PL_toptarget)
a0d0e21e 1205 {
4633a7c4
LW		 1206 GV *fgv;
1207 CV *cv;
a0d0e21e
LW		 1208 if (!IoTOP_GV(io)) {
1209 GV *topgv;
46fc3d4c 1210 SV *topname;
a0d0e21e
LW		 1211
1212 if (!IoTOP_NAME(io)) {
1213 if (!IoFMT_NAME(io))
1214 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c 1215 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1216 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1217 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1218 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1219 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1220 else
1221 IoTOP_NAME(io) = savepv("top");
1222 }
1223 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1224 if (!topgv || !GvFORM(topgv)) {
1225 IoLINES_LEFT(io) = 100000000;
1226 goto forget_top;
1227 }
1228 IoTOP_GV(io) = topgv;
1229 }
748a9306
LW		 1230 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1231 I32 lines = IoLINES_LEFT(io);
3280af22 1232 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1233 if (lines <= 0) /* Yow, header didn't even fit!!! */
1234 goto forget_top;
748a9306
LW		 1235 while (lines-- > 0) {
1236 s = strchr(s, '\n');
1237 if (!s)
1238 break;
1239 s++;
1240 }
1241 if (s) {
3280af22
NIS		 1242 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1243 sv_chop(PL_formtarget, s);
1244 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1245 }
1246 }
a0d0e21e 1247 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1248 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1249 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1250 IoPAGE(io)++;
3280af22 1251 PL_formtarget = PL_toptarget;
748a9306 1252 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1253 fgv = IoTOP_GV(io);
1254 if (!fgv)
1255 DIE("bad top format reference");
1256 cv = GvFORM(fgv);
1257 if (!cv) {
1258 SV *tmpsv = sv_newmortal();
aac0dd9a 1259 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW		 1260 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1261 }
44a8e56a 1262 if (CvCLONE(cv))
1263 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1264 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1265 }
1266
1267 forget_top:
3280af22 1268 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1269 POPFORMAT(cx);
1270 LEAVE;
1271
1272 fp = IoOFP(io);
1273 if (!fp) {
599cee73 1274 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
a0d0e21e 1275 if (IoIFP(io))
599cee73
PM		 1276 warner(WARN_IO, "Filehandle only opened for input");
1277 else if (ckWARN(WARN_CLOSED))
1278 warner(WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1279 }
3280af22 1280 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1281 }
1282 else {
3280af22 1283 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73
PM		 1284 if (ckWARN(WARN_IO))
1285 warner(WARN_IO, "page overflow");
a0d0e21e 1286 }
3280af22 1287 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1288 PerlIO_error(fp))
3280af22 1289 PUSHs(&PL_sv_no);
a0d0e21e 1290 else {
3280af22
NIS		 1291 FmLINES(PL_formtarget) = 0;
1292 SvCUR_set(PL_formtarget, 0);
1293 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1294 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1295 (void)PerlIO_flush(fp);
3280af22 1296 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1297 }
1298 }
3280af22 1299 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1300 PUTBACK;
1301 return pop_return();
1302}
1303
1304PP(pp_prtf)
1305{
4e35701f 1306 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1307 GV *gv;
1308 IO *io;
760ac839 1309 PerlIO *fp;
26db47c4 1310 SV *sv;
46fc3d4c 1311 MAGIC *mg;
2d8e6c8d 1312 STRLEN n_a;
a0d0e21e 1313
533c011a 1314 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1315 gv = (GV*)*++MARK;
1316 else
3280af22 1317 gv = PL_defoutgv;
46fc3d4c 1318
33c27489 1319 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1320 if (MARK == ORIGMARK) {
4352c267 1321 MEXTEND(SP, 1);
46fc3d4c 1322 ++MARK;
1323 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1324 ++SP;
1325 }
1326 PUSHMARK(MARK - 1);
33c27489 1327 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1328 PUTBACK;
1329 ENTER;
1330 perl_call_method("PRINTF", G_SCALAR);
1331 LEAVE;
1332 SPAGAIN;
1333 MARK = ORIGMARK + 1;
1334 *MARK = *SP;
1335 SP = MARK;
1336 RETURN;
1337 }
1338
26db47c4 1339 sv = NEWSV(0,0);
a0d0e21e 1340 if (!(io = GvIO(gv))) {
599cee73 1341 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1342 gv_fullname3(sv, gv, Nullch);
2d8e6c8d 1343 warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1344 }
1345 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1346 goto just_say_no;
1347 }
1348 else if (!(fp = IoOFP(io))) {
599cee73 1349 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1350 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1351 if (IoIFP(io))
599cee73 1352 warner(WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 1353 SvPV(sv,n_a));
599cee73
PM		 1354 else if (ckWARN(WARN_CLOSED))
1355 warner(WARN_CLOSED, "printf on closed filehandle %s",
2d8e6c8d 1356 SvPV(sv,n_a));
a0d0e21e 1357 }
748a9306 1358 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1359 goto just_say_no;
1360 }
1361 else {
36477c24 1362#ifdef USE_LOCALE_NUMERIC
533c011a 1363 if (PL_op->op_private & OPpLOCALE)
36477c24 1364 SET_NUMERIC_LOCAL();
bbce6d69 1365 else
36477c24 1366 SET_NUMERIC_STANDARD();
1367#endif
a0d0e21e
LW		 1368 do_sprintf(sv, SP - MARK, MARK + 1);
1369 if (!do_print(sv, fp))
1370 goto just_say_no;
1371
1372 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1373 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1374 goto just_say_no;
1375 }
1376 SvREFCNT_dec(sv);
1377 SP = ORIGMARK;
3280af22 1378 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1379 RETURN;
1380
1381 just_say_no:
1382 SvREFCNT_dec(sv);
1383 SP = ORIGMARK;
3280af22 1384 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1385 RETURN;
1386}
1387
c07a80fd 1388PP(pp_sysopen)
1389{
4e35701f 1390 djSP;
c07a80fd 1391 GV *gv;
c07a80fd 1392 SV *sv;
1393 char *tmps;
1394 STRLEN len;
1395 int mode, perm;
1396
1397 if (MAXARG > 3)
1398 perm = POPi;
1399 else
1400 perm = 0666;
1401 mode = POPi;
1402 sv = POPs;
1403 gv = (GV *)POPs;
1404
4592e6ca
NIS		 1405 /* Need TIEHANDLE method ? */
1406
c07a80fd 1407 tmps = SvPV(sv, len);
1408 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1409 IoLINES(GvIOp(gv)) = 0;
3280af22 1410 PUSHs(&PL_sv_yes);
c07a80fd 1411 }
1412 else {
3280af22 1413 PUSHs(&PL_sv_undef);
c07a80fd 1414 }
1415 RETURN;
1416}
1417
a0d0e21e
LW		 1418PP(pp_sysread)
1419{
4e35701f 1420 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1421 int offset;
1422 GV *gv;
1423 IO *io;
1424 char *buffer;
5b54f415 1425 SSize_t length;
1e422769 1426 Sock_size_t bufsize;
748a9306 1427 SV *bufsv;
a0d0e21e 1428 STRLEN blen;
2ae324a7 1429 MAGIC *mg;
a0d0e21e
LW		 1430
1431 gv = (GV*)*++MARK;
533c011a 1432 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1433 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1434 {
2ae324a7 1435 SV *sv;
1436
1437 PUSHMARK(MARK-1);
33c27489 1438 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1439 ENTER;
1440 perl_call_method("READ", G_SCALAR);
1441 LEAVE;
1442 SPAGAIN;
1443 sv = POPs;
1444 SP = ORIGMARK;
1445 PUSHs(sv);
1446 RETURN;
1447 }
1448
a0d0e21e
LW		 1449 if (!gv)
1450 goto say_undef;
748a9306 1451 bufsv = *++MARK;
ff68c719 1452 if (! SvOK(bufsv))
1453 sv_setpvn(bufsv, "", 0);
748a9306 1454 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1455 length = SvIVx(*++MARK);
1456 if (length < 0)
1457 DIE("Negative length");
748a9306 1458 SETERRNO(0,0);
a0d0e21e
LW		 1459 if (MARK < SP)
1460 offset = SvIVx(*++MARK);
1461 else
1462 offset = 0;
1463 io = GvIO(gv);
1464 if (!io || !IoIFP(io))
1465 goto say_undef;
1466#ifdef HAS_SOCKET
533c011a 1467 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1468 char namebuf[MAXPATHLEN];
eec2d3df 1469#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1470 bufsize = sizeof (struct sockaddr_in);
1471#else
46fc3d4c 1472 bufsize = sizeof namebuf;
490ab354 1473#endif
748a9306 1474 buffer = SvGROW(bufsv, length+1);
bbce6d69 1475 /* 'offset' means 'flags' here */
6ad3d225 1476 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1477 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1478 if (length < 0)
1479 RETPUSHUNDEF;
748a9306
LW		 1480 SvCUR_set(bufsv, length);
1481 *SvEND(bufsv) = '\0';
1482 (void)SvPOK_only(bufsv);
1483 SvSETMAGIC(bufsv);
aac0dd9a 1484 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1485 if (!(IoFLAGS(io) & IOf_UNTAINT))
1486 SvTAINTED_on(bufsv);
a0d0e21e 1487 SP = ORIGMARK;
46fc3d4c 1488 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1489 PUSHs(TARG);
1490 RETURN;
1491 }
1492#else
911d147d 1493 if (PL_op->op_type == OP_RECV)
22c35a8c 1494 DIE(PL_no_sock_func, "recv");
a0d0e21e 1495#endif
bbce6d69 1496 if (offset < 0) {
1497 if (-offset > blen)
1498 DIE("Offset outside string");
1499 offset += blen;
1500 }
cd52b7b2 1501 bufsize = SvCUR(bufsv);
748a9306 1502 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1503 if (offset > bufsize) { /* Zero any newly allocated space */
1504 Zero(buffer+bufsize, offset-bufsize, char);
1505 }
533c011a 1506 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS		 1507#ifdef PERL_SOCK_SYSREAD_IS_RECV
1508 if (IoTYPE(io) == 's') {
1509 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1510 buffer+offset, length, 0);
1511 }
1512 else
1513#endif
1514 {
1515 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1516 buffer+offset, length);
1517 }
a0d0e21e
LW		 1518 }
1519 else
1520#ifdef HAS_SOCKET__bad_code_maybe
1521 if (IoTYPE(io) == 's') {
46fc3d4c 1522 char namebuf[MAXPATHLEN];
490ab354
JH		 1523#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1524 bufsize = sizeof (struct sockaddr_in);
1525#else
46fc3d4c 1526 bufsize = sizeof namebuf;
490ab354 1527#endif
6ad3d225 1528 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1529 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1530 }
1531 else
1532#endif
3b02c43c 1533 {
760ac839 1534 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1535 /* fread() returns 0 on both error and EOF */
5c7a8c78 1536 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1537 length = -1;
1538 }
a0d0e21e
LW		 1539 if (length < 0)
1540 goto say_undef;
748a9306
LW		 1541 SvCUR_set(bufsv, length+offset);
1542 *SvEND(bufsv) = '\0';
1543 (void)SvPOK_only(bufsv);
1544 SvSETMAGIC(bufsv);
aac0dd9a 1545 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1546 if (!(IoFLAGS(io) & IOf_UNTAINT))
1547 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1548 SP = ORIGMARK;
1549 PUSHi(length);
1550 RETURN;
1551
1552 say_undef:
1553 SP = ORIGMARK;
1554 RETPUSHUNDEF;
1555}
1556
1557PP(pp_syswrite)
1558{
092bebab
JH		 1559 djSP;
1560 int items = (SP - PL_stack_base) - TOPMARK;
1561 if (items == 2) {
9f089d78 1562 SV *sv;
092bebab 1563 EXTEND(SP, 1);
9f089d78
SB		 1564 sv = sv_2mortal(newSViv(sv_len(*SP)));
1565 PUSHs(sv);
092bebab
JH		 1566 PUTBACK;
1567 }
a0d0e21e
LW		 1568 return pp_send(ARGS);
1569}
1570
1571PP(pp_send)
1572{
4e35701f 1573 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1574 GV *gv;
1575 IO *io;
1576 int offset;
748a9306 1577 SV *bufsv;
a0d0e21e
LW		 1578 char *buffer;
1579 int length;
1580 STRLEN blen;
1d603a67 1581 MAGIC *mg;
a0d0e21e
LW		 1582
1583 gv = (GV*)*++MARK;
33c27489 1584 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1585 SV *sv;
1586
1587 PUSHMARK(MARK-1);
33c27489 1588 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67
GB		 1589 ENTER;
1590 perl_call_method("WRITE", G_SCALAR);
1591 LEAVE;
1592 SPAGAIN;
1593 sv = POPs;
1594 SP = ORIGMARK;
1595 PUSHs(sv);
1596 RETURN;
1597 }
a0d0e21e
LW		 1598 if (!gv)
1599 goto say_undef;
748a9306
LW		 1600 bufsv = *++MARK;
1601 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1602 length = SvIVx(*++MARK);
1603 if (length < 0)
1604 DIE("Negative length");
748a9306 1605 SETERRNO(0,0);
a0d0e21e
LW		 1606 io = GvIO(gv);
1607 if (!io || !IoIFP(io)) {
1608 length = -1;
599cee73 1609 if (ckWARN(WARN_CLOSED)) {
533c011a 1610 if (PL_op->op_type == OP_SYSWRITE)
599cee73 1611 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1612 else
599cee73 1613 warner(WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1614 }
1615 }
533c011a 1616 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1617 if (MARK < SP) {
a0d0e21e 1618 offset = SvIVx(*++MARK);
bbce6d69 1619 if (offset < 0) {
1620 if (-offset > blen)
1621 DIE("Offset outside string");
1622 offset += blen;
fb73857a 1623 } else if (offset >= blen && blen > 0)
bbce6d69 1624 DIE("Offset outside string");
1625 } else
a0d0e21e
LW		 1626 offset = 0;
1627 if (length > blen - offset)
1628 length = blen - offset;
a7092146
GS		 1629#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1630 if (IoTYPE(io) == 's') {
1631 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1632 buffer+offset, length, 0);
1633 }
1634 else
1635#endif
1636 {
1637 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1638 buffer+offset, length);
1639 }
a0d0e21e
LW		 1640 }
1641#ifdef HAS_SOCKET
1642 else if (SP > MARK) {
1643 char *sockbuf;
1644 STRLEN mlen;
1645 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1646 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1647 (struct sockaddr *)sockbuf, mlen);
1648 }
1649 else
6ad3d225 1650 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1651
a0d0e21e
LW		 1652#else
1653 else
22c35a8c 1654 DIE(PL_no_sock_func, "send");
a0d0e21e
LW		 1655#endif
1656 if (length < 0)
1657 goto say_undef;
1658 SP = ORIGMARK;
1659 PUSHi(length);
1660 RETURN;
1661
1662 say_undef:
1663 SP = ORIGMARK;
1664 RETPUSHUNDEF;
1665}
1666
1667PP(pp_recv)
1668{
1669 return pp_sysread(ARGS);
1670}
1671
1672PP(pp_eof)
1673{
4e35701f 1674 djSP;
a0d0e21e 1675 GV *gv;
4592e6ca 1676 MAGIC *mg;
a0d0e21e
LW		 1677
1678 if (MAXARG <= 0)
3280af22 1679 gv = PL_last_in_gv;
a0d0e21e 1680 else
3280af22 1681 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1682
1683 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1684 PUSHMARK(SP);
1685 XPUSHs(SvTIED_obj((SV*)gv, mg));
1686 PUTBACK;
1687 ENTER;
1688 perl_call_method("EOF", G_SCALAR);
1689 LEAVE;
1690 SPAGAIN;
1691 RETURN;
1692 }
1693
54310121 1694 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1695 RETURN;
1696}
1697
1698PP(pp_tell)
1699{
4e35701f 1700 djSP; dTARGET;
4592e6ca
NIS		 1701 GV *gv;
1702 MAGIC *mg;
a0d0e21e
LW		 1703
1704 if (MAXARG <= 0)
3280af22 1705 gv = PL_last_in_gv;
a0d0e21e 1706 else
3280af22 1707 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1708
1709 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1710 PUSHMARK(SP);
1711 XPUSHs(SvTIED_obj((SV*)gv, mg));
1712 PUTBACK;
1713 ENTER;
1714 perl_call_method("TELL", G_SCALAR);
1715 LEAVE;
1716 SPAGAIN;
1717 RETURN;
1718 }
1719
a0d0e21e
LW		 1720 PUSHi( do_tell(gv) );
1721 RETURN;
1722}
1723
1724PP(pp_seek)
1725{
137443ea 1726 return pp_sysseek(ARGS);
1727}
1728
1729PP(pp_sysseek)
1730{
4e35701f 1731 djSP;
a0d0e21e
LW		 1732 GV *gv;
1733 int whence = POPi;
97cc44eb 1734 Off_t offset = POPl;
4592e6ca 1735 MAGIC *mg;
a0d0e21e 1736
3280af22 1737 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1738
1739 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1740 PUSHMARK(SP);
1741 XPUSHs(SvTIED_obj((SV*)gv, mg));
1742 XPUSHs(sv_2mortal(newSViv((IV) offset)));
1743 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1744 PUTBACK;
1745 ENTER;
1746 perl_call_method("SEEK", G_SCALAR);
1747 LEAVE;
1748 SPAGAIN;
1749 RETURN;
1750 }
1751
533c011a 1752 if (PL_op->op_type == OP_SEEK)
8903cb82 1753 PUSHs(boolSV(do_seek(gv, offset, whence)));
1754 else {
97cc44eb 1755 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1756 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1757 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1758 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1759 }
a0d0e21e
LW		 1760 RETURN;
1761}
1762
1763PP(pp_truncate)
1764{
4e35701f 1765 djSP;
a0d0e21e
LW		 1766 Off_t len = (Off_t)POPn;
1767 int result = 1;
1768 GV *tmpgv;
2d8e6c8d 1769 STRLEN n_a;
a0d0e21e 1770
748a9306 1771 SETERRNO(0,0);
5d94fbed 1772#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1773 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1774 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1775 do_ftruncate:
1e422769 1776 TAINT_PROPER("truncate");
a0d0e21e 1777 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1778#ifdef HAS_TRUNCATE
760ac839 1779 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1780#else
760ac839 1781 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1782#endif
a0d0e21e
LW		 1783 result = 0;
1784 }
1785 else {
cbdc8872 1786 SV *sv = POPs;
1e422769 1787 char *name;
2d8e6c8d 1788 STRLEN n_a;
1e422769 1789
cbdc8872 1790 if (SvTYPE(sv) == SVt_PVGV) {
1791 tmpgv = (GV*)sv; /* *main::FRED for example */
1792 goto do_ftruncate;
1793 }
1794 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1795 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1796 goto do_ftruncate;
1797 }
1e422769 1798
2d8e6c8d 1799 name = SvPV(sv, n_a);
1e422769 1800 TAINT_PROPER("truncate");
cbdc8872 1801#ifdef HAS_TRUNCATE
1e422769 1802 if (truncate(name, len) < 0)
a0d0e21e 1803 result = 0;
cbdc8872 1804#else
1805 {
1806 int tmpfd;
6ad3d225 1807 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1808 result = 0;
cbdc8872 1809 else {
1810 if (my_chsize(tmpfd, len) < 0)
1811 result = 0;
6ad3d225 1812 PerlLIO_close(tmpfd);
cbdc8872 1813 }
a0d0e21e 1814 }
a0d0e21e 1815#endif
cbdc8872 1816 }
a0d0e21e
LW		 1817
1818 if (result)
1819 RETPUSHYES;
1820 if (!errno)
748a9306 1821 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1822 RETPUSHUNDEF;
1823#else
1824 DIE("truncate not implemented");
1825#endif
1826}
1827
1828PP(pp_fcntl)
1829{
1830 return pp_ioctl(ARGS);
1831}
1832
1833PP(pp_ioctl)
1834{
4e35701f 1835 djSP; dTARGET;
748a9306 1836 SV *argsv = POPs;
a0d0e21e 1837 unsigned int func = U_I(POPn);
533c011a 1838 int optype = PL_op->op_type;
a0d0e21e 1839 char *s;
324aa91a 1840 IV retval;
a0d0e21e
LW		 1841 GV *gv = (GV*)POPs;
1842 IO *io = GvIOn(gv);
1843
748a9306
LW		 1844 if (!io || !argsv || !IoIFP(io)) {
1845 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1846 RETPUSHUNDEF;
1847 }
1848
748a9306 1849 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1850 STRLEN len;
324aa91a 1851 STRLEN need;
748a9306 1852 s = SvPV_force(argsv, len);
324aa91a
HF		 1853 need = IOCPARM_LEN(func);
1854 if (len < need) {
1855 s = Sv_Grow(argsv, need + 1);
1856 SvCUR_set(argsv, need);
a0d0e21e
LW		 1857 }
1858
748a9306 1859 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1860 }
1861 else {
748a9306 1862 retval = SvIV(argsv);
a0d0e21e 1863 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1864 }
1865
1866 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1867
1868 if (optype == OP_IOCTL)
1869#ifdef HAS_IOCTL
76e3520e 1870 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1871#else
1872 DIE("ioctl is not implemented");
1873#endif
1874 else
55497cff 1875#ifdef HAS_FCNTL
1876#if defined(OS2) && defined(__EMX__)
760ac839 1877 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1878#else
760ac839 1879 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1880#endif
1881#else
a0d0e21e 1882 DIE("fcntl is not implemented");
a0d0e21e
LW		 1883#endif
1884
748a9306
LW		 1885 if (SvPOK(argsv)) {
1886 if (s[SvCUR(argsv)] != 17)
a0d0e21e 1887 DIE("Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1888 PL_op_name[optype]);
748a9306
LW		 1889 s[SvCUR(argsv)] = 0; /* put our null back */
1890 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1891 }
1892
1893 if (retval == -1)
1894 RETPUSHUNDEF;
1895 if (retval != 0) {
1896 PUSHi(retval);
1897 }
1898 else {
8903cb82 1899 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1900 }
1901 RETURN;
1902}
1903
1904PP(pp_flock)
1905{
4e35701f 1906 djSP; dTARGET;
a0d0e21e
LW		 1907 I32 value;
1908 int argtype;
1909 GV *gv;
760ac839 1910 PerlIO *fp;
16d20bd9 1911
ff68c719 1912#ifdef FLOCK
a0d0e21e
LW		 1913 argtype = POPi;
1914 if (MAXARG <= 0)
3280af22 1915 gv = PL_last_in_gv;
a0d0e21e
LW		 1916 else
1917 gv = (GV*)POPs;
1918 if (gv && GvIO(gv))
1919 fp = IoIFP(GvIOp(gv));
1920 else
1921 fp = Nullfp;
1922 if (fp) {
68dc0745 1923 (void)PerlIO_flush(fp);
76e3520e 1924 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1925 }
1926 else
1927 value = 0;
1928 PUSHi(value);
1929 RETURN;
1930#else
22c35a8c 1931 DIE(PL_no_func, "flock()");
a0d0e21e
LW		 1932#endif
1933}
1934
1935/* Sockets. */
1936
1937PP(pp_socket)
1938{
4e35701f 1939 djSP;
a0d0e21e
LW		 1940#ifdef HAS_SOCKET
1941 GV *gv;
1942 register IO *io;
1943 int protocol = POPi;
1944 int type = POPi;
1945 int domain = POPi;
1946 int fd;
1947
1948 gv = (GV*)POPs;
1949
1950 if (!gv) {
748a9306 1951 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1952 RETPUSHUNDEF;
1953 }
1954
1955 io = GvIOn(gv);
1956 if (IoIFP(io))
1957 do_close(gv, FALSE);
1958
1959 TAINT_PROPER("socket");
6ad3d225 1960 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1961 if (fd < 0)
1962 RETPUSHUNDEF;
760ac839
LW		 1963 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1964 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1965 IoTYPE(io) = 's';
1966 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1967 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1968 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1969 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1970 RETPUSHUNDEF;
1971 }
1972
1973 RETPUSHYES;
1974#else
22c35a8c 1975 DIE(PL_no_sock_func, "socket");
a0d0e21e
LW		 1976#endif
1977}
1978
1979PP(pp_sockpair)
1980{
4e35701f 1981 djSP;
a0d0e21e
LW		 1982#ifdef HAS_SOCKETPAIR
1983 GV *gv1;
1984 GV *gv2;
1985 register IO *io1;
1986 register IO *io2;
1987 int protocol = POPi;
1988 int type = POPi;
1989 int domain = POPi;
1990 int fd[2];
1991
1992 gv2 = (GV*)POPs;
1993 gv1 = (GV*)POPs;
1994 if (!gv1 || !gv2)
1995 RETPUSHUNDEF;
1996
1997 io1 = GvIOn(gv1);
1998 io2 = GvIOn(gv2);
1999 if (IoIFP(io1))
2000 do_close(gv1, FALSE);
2001 if (IoIFP(io2))
2002 do_close(gv2, FALSE);
2003
2004 TAINT_PROPER("socketpair");
6ad3d225 2005 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2006 RETPUSHUNDEF;
760ac839
LW		 2007 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2008 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2009 IoTYPE(io1) = 's';
760ac839
LW		 2010 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2011 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 2012 IoTYPE(io2) = 's';
2013 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2014 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2015 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2016 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2017 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2018 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2019 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2020 RETPUSHUNDEF;
2021 }
2022
2023 RETPUSHYES;
2024#else
22c35a8c 2025 DIE(PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2026#endif
2027}
2028
2029PP(pp_bind)
2030{
4e35701f 2031 djSP;
a0d0e21e 2032#ifdef HAS_SOCKET
eec2d3df
GS		 2033#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2034 extern GETPRIVMODE();
2035 extern GETUSERMODE();
2036#endif
748a9306 2037 SV *addrsv = POPs;
a0d0e21e
LW		 2038 char *addr;
2039 GV *gv = (GV*)POPs;
2040 register IO *io = GvIOn(gv);
2041 STRLEN len;
eec2d3df
GS		 2042 int bind_ok = 0;
2043#ifdef MPE
2044 int mpeprivmode = 0;
2045#endif
a0d0e21e
LW		 2046
2047 if (!io || !IoIFP(io))
2048 goto nuts;
2049
748a9306 2050 addr = SvPV(addrsv, len);
a0d0e21e 2051 TAINT_PROPER("bind");
eec2d3df
GS		 2052#ifdef MPE /* Deal with MPE bind() peculiarities */
2053 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2054 /* The address *MUST* stupidly be zero. */
2055 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2056 /* PRIV mode is required to bind() to ports < 1024. */
2057 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2058 ((struct sockaddr_in *)addr)->sin_port > 0) {
2059 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2060 mpeprivmode = 1;
2061 }
2062 }
2063#endif /* MPE */
2064 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2065 (struct sockaddr *)addr, len) >= 0)
2066 bind_ok = 1;
2067
2068#ifdef MPE /* Switch back to USER mode */
2069 if (mpeprivmode)
2070 GETUSERMODE();
2071#endif /* MPE */
2072
2073 if (bind_ok)
a0d0e21e
LW		 2074 RETPUSHYES;
2075 else
2076 RETPUSHUNDEF;
2077
2078nuts:
599cee73
PM		 2079 if (ckWARN(WARN_CLOSED))
2080 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 2081 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2082 RETPUSHUNDEF;
2083#else
22c35a8c 2084 DIE(PL_no_sock_func, "bind");
a0d0e21e
LW		 2085#endif
2086}
2087
2088PP(pp_connect)
2089{
4e35701f 2090 djSP;
a0d0e21e 2091#ifdef HAS_SOCKET
748a9306 2092 SV *addrsv = POPs;
a0d0e21e
LW		 2093 char *addr;
2094 GV *gv = (GV*)POPs;
2095 register IO *io = GvIOn(gv);
2096 STRLEN len;
2097
2098 if (!io || !IoIFP(io))
2099 goto nuts;
2100
748a9306 2101 addr = SvPV(addrsv, len);
a0d0e21e 2102 TAINT_PROPER("connect");
6ad3d225 2103 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2104 RETPUSHYES;
2105 else
2106 RETPUSHUNDEF;
2107
2108nuts:
599cee73
PM		 2109 if (ckWARN(WARN_CLOSED))
2110 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 2111 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2112 RETPUSHUNDEF;
2113#else
22c35a8c 2114 DIE(PL_no_sock_func, "connect");
a0d0e21e
LW		 2115#endif
2116}
2117
2118PP(pp_listen)
2119{
4e35701f 2120 djSP;
a0d0e21e
LW		 2121#ifdef HAS_SOCKET
2122 int backlog = POPi;
2123 GV *gv = (GV*)POPs;
2124 register IO *io = GvIOn(gv);
2125
2126 if (!io || !IoIFP(io))
2127 goto nuts;
2128
6ad3d225 2129 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2130 RETPUSHYES;
2131 else
2132 RETPUSHUNDEF;
2133
2134nuts:
599cee73
PM		 2135 if (ckWARN(WARN_CLOSED))
2136 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 2137 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2138 RETPUSHUNDEF;
2139#else
22c35a8c 2140 DIE(PL_no_sock_func, "listen");
a0d0e21e
LW		 2141#endif
2142}
2143
2144PP(pp_accept)
2145{
4e35701f 2146 djSP; dTARGET;
a0d0e21e
LW		 2147#ifdef HAS_SOCKET
2148 GV *ngv;
2149 GV *ggv;
2150 register IO *nstio;
2151 register IO *gstio;
4633a7c4 2152 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2153 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2154 int fd;
2155
2156 ggv = (GV*)POPs;
2157 ngv = (GV*)POPs;
2158
2159 if (!ngv)
2160 goto badexit;
2161 if (!ggv)
2162 goto nuts;
2163
2164 gstio = GvIO(ggv);
2165 if (!gstio || !IoIFP(gstio))
2166 goto nuts;
2167
2168 nstio = GvIOn(ngv);
2169 if (IoIFP(nstio))
2170 do_close(ngv, FALSE);
2171
6ad3d225 2172 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2173 if (fd < 0)
2174 goto badexit;
760ac839
LW		 2175 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2176 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2177 IoTYPE(nstio) = 's';
2178 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2179 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2180 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2181 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2182 goto badexit;
2183 }
2184
748a9306 2185 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2186 RETURN;
2187
2188nuts:
599cee73
PM		 2189 if (ckWARN(WARN_CLOSED))
2190 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2191 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2192
2193badexit:
2194 RETPUSHUNDEF;
2195
2196#else
22c35a8c 2197 DIE(PL_no_sock_func, "accept");
a0d0e21e
LW		 2198#endif
2199}
2200
2201PP(pp_shutdown)
2202{
4e35701f 2203 djSP; dTARGET;
a0d0e21e
LW		 2204#ifdef HAS_SOCKET
2205 int how = POPi;
2206 GV *gv = (GV*)POPs;
2207 register IO *io = GvIOn(gv);
2208
2209 if (!io || !IoIFP(io))
2210 goto nuts;
2211
6ad3d225 2212 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2213 RETURN;
2214
2215nuts:
599cee73
PM		 2216 if (ckWARN(WARN_CLOSED))
2217 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2218 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2219 RETPUSHUNDEF;
2220#else
22c35a8c 2221 DIE(PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2222#endif
2223}
2224
2225PP(pp_gsockopt)
2226{
2227#ifdef HAS_SOCKET
2228 return pp_ssockopt(ARGS);
2229#else
22c35a8c 2230 DIE(PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2231#endif
2232}
2233
2234PP(pp_ssockopt)
2235{
4e35701f 2236 djSP;
a0d0e21e 2237#ifdef HAS_SOCKET
533c011a 2238 int optype = PL_op->op_type;
a0d0e21e
LW		 2239 SV *sv;
2240 int fd;
2241 unsigned int optname;
2242 unsigned int lvl;
2243 GV *gv;
2244 register IO *io;
1e422769 2245 Sock_size_t len;
a0d0e21e
LW		 2246
2247 if (optype == OP_GSOCKOPT)
2248 sv = sv_2mortal(NEWSV(22, 257));
2249 else
2250 sv = POPs;
2251 optname = (unsigned int) POPi;
2252 lvl = (unsigned int) POPi;
2253
2254 gv = (GV*)POPs;
2255 io = GvIOn(gv);
2256 if (!io || !IoIFP(io))
2257 goto nuts;
2258
760ac839 2259 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2260 switch (optype) {
2261 case OP_GSOCKOPT:
748a9306 2262 SvGROW(sv, 257);
a0d0e21e 2263 (void)SvPOK_only(sv);
748a9306
LW		 2264 SvCUR_set(sv,256);
2265 *SvEND(sv) ='\0';
1e422769 2266 len = SvCUR(sv);
6ad3d225 2267 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2268 goto nuts2;
1e422769 2269 SvCUR_set(sv, len);
748a9306 2270 *SvEND(sv) ='\0';
a0d0e21e
LW		 2271 PUSHs(sv);
2272 break;
2273 case OP_SSOCKOPT: {
1e422769 2274 char *buf;
2275 int aint;
2276 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2277 STRLEN l;
2278 buf = SvPV(sv, l);
2279 len = l;
1e422769 2280 }
56ee1660 2281 else {
a0d0e21e
LW		 2282 aint = (int)SvIV(sv);
2283 buf = (char*)&aint;
2284 len = sizeof(int);
2285 }
6ad3d225 2286 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2287 goto nuts2;
3280af22 2288 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2289 }
2290 break;
2291 }
2292 RETURN;
2293
2294nuts:
599cee73
PM		 2295 if (ckWARN(WARN_CLOSED))
2296 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2297 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2298nuts2:
2299 RETPUSHUNDEF;
2300
2301#else
22c35a8c 2302 DIE(PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2303#endif
2304}
2305
2306PP(pp_getsockname)
2307{
2308#ifdef HAS_SOCKET
2309 return pp_getpeername(ARGS);
2310#else
22c35a8c 2311 DIE(PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2312#endif
2313}
2314
2315PP(pp_getpeername)
2316{
4e35701f 2317 djSP;
a0d0e21e 2318#ifdef HAS_SOCKET
533c011a 2319 int optype = PL_op->op_type;
a0d0e21e
LW		 2320 SV *sv;
2321 int fd;
2322 GV *gv = (GV*)POPs;
2323 register IO *io = GvIOn(gv);
1e422769 2324 Sock_size_t len;
a0d0e21e
LW		 2325
2326 if (!io || !IoIFP(io))
2327 goto nuts;
2328
2329 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2330 (void)SvPOK_only(sv);
1e422769 2331 len = 256;
2332 SvCUR_set(sv, len);
748a9306 2333 *SvEND(sv) ='\0';
760ac839 2334 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2335 switch (optype) {
2336 case OP_GETSOCKNAME:
6ad3d225 2337 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2338 goto nuts2;
2339 break;
2340 case OP_GETPEERNAME:
6ad3d225 2341 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2342 goto nuts2;
490ab354
JH		 2343#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2344 {
2345 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2346 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2347 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2348 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2349 sizeof(u_short) + sizeof(struct in_addr))) {
2350 goto nuts2;
2351 }
2352 }
2353#endif
a0d0e21e
LW		 2354 break;
2355 }
13826f2c
CS		 2356#ifdef BOGUS_GETNAME_RETURN
2357 /* Interactive Unix, getpeername() and getsockname()
2358 does not return valid namelen */
1e422769 2359 if (len == BOGUS_GETNAME_RETURN)
2360 len = sizeof(struct sockaddr);
13826f2c 2361#endif
1e422769 2362 SvCUR_set(sv, len);
748a9306 2363 *SvEND(sv) ='\0';
a0d0e21e
LW		 2364 PUSHs(sv);
2365 RETURN;
2366
2367nuts:
599cee73
PM		 2368 if (ckWARN(WARN_CLOSED))
2369 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2370 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2371nuts2:
2372 RETPUSHUNDEF;
2373
2374#else
22c35a8c 2375 DIE(PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2376#endif
2377}
2378
2379/* Stat calls. */
2380
2381PP(pp_lstat)
2382{
2383 return pp_stat(ARGS);
2384}
2385
2386PP(pp_stat)
2387{
4e35701f 2388 djSP;
a0d0e21e 2389 GV *tmpgv;
54310121 2390 I32 gimme;
a0d0e21e 2391 I32 max = 13;
2d8e6c8d 2392 STRLEN n_a;
a0d0e21e 2393
533c011a 2394 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2395 tmpgv = cGVOP->op_gv;
748a9306 2396 do_fstat:
3280af22
NIS		 2397 if (tmpgv != PL_defgv) {
2398 PL_laststype = OP_STAT;
2399 PL_statgv = tmpgv;
2400 sv_setpv(PL_statname, "");
2401 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2402 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2403 }
3280af22 2404 if (PL_laststatval < 0)
a0d0e21e
LW		 2405 max = 0;
2406 }
2407 else {
748a9306
LW		 2408 SV* sv = POPs;
2409 if (SvTYPE(sv) == SVt_PVGV) {
2410 tmpgv = (GV*)sv;
2411 goto do_fstat;
2412 }
2413 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2414 tmpgv = (GV*)SvRV(sv);
2415 goto do_fstat;
2416 }
2d8e6c8d 2417 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2418 PL_statgv = Nullgv;
a0d0e21e 2419#ifdef HAS_LSTAT
533c011a
NIS		 2420 PL_laststype = PL_op->op_type;
2421 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2422 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2423 else
2424#endif
2d8e6c8d 2425 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2426 if (PL_laststatval < 0) {
2d8e6c8d 2427 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
22c35a8c 2428 warner(WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2429 max = 0;
2430 }
2431 }
2432
54310121 2433 gimme = GIMME_V;
2434 if (gimme != G_ARRAY) {
2435 if (gimme != G_VOID)
2436 XPUSHs(boolSV(max));
2437 RETURN;
a0d0e21e
LW		 2438 }
2439 if (max) {
36477c24 2440 EXTEND(SP, max);
2441 EXTEND_MORTAL(max);
3280af22
NIS		 2442 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2443 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2444 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2445 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2446 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2447 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2448#ifdef USE_STAT_RDEV
3280af22 2449 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2450#else
79cb57f6 2451 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2452#endif
3280af22 2453 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2454#ifdef BIG_TIME
6b88bc9c
GS		 2455 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2456 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2457 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2458#else
3280af22
NIS		 2459 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2460 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2461 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2462#endif
a0d0e21e 2463#ifdef USE_STAT_BLOCKS
3280af22
NIS		 2464 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2465 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e 2466#else
79cb57f6
GS		 2467 PUSHs(sv_2mortal(newSVpvn("", 0)));
2468 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2469#endif
2470 }
2471 RETURN;
2472}
2473
2474PP(pp_ftrread)
2475{
5ff3f7a4 2476 I32 result;
4e35701f 2477 djSP;
5ff3f7a4 2478#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2479 STRLEN n_a;
5ff3f7a4 2480 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2481 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2482 if (result == 0)
2483 RETPUSHYES;
2484 if (result < 0)
2485 RETPUSHUNDEF;
2486 RETPUSHNO;
22865c03
GS		 2487 }
2488 else
5ff3f7a4
GS		 2489 result = my_stat(ARGS);
2490#else
2491 result = my_stat(ARGS);
2492#endif
22865c03 2493 SPAGAIN;
a0d0e21e
LW		 2494 if (result < 0)
2495 RETPUSHUNDEF;
3280af22 2496 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2497 RETPUSHYES;
2498 RETPUSHNO;
2499}
2500
2501PP(pp_ftrwrite)
2502{
5ff3f7a4 2503 I32 result;
4e35701f 2504 djSP;
5ff3f7a4 2505#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2506 STRLEN n_a;
5ff3f7a4 2507 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2508 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2509 if (result == 0)
2510 RETPUSHYES;
2511 if (result < 0)
2512 RETPUSHUNDEF;
2513 RETPUSHNO;
22865c03
GS		 2514 }
2515 else
5ff3f7a4
GS		 2516 result = my_stat(ARGS);
2517#else
2518 result = my_stat(ARGS);
2519#endif
22865c03 2520 SPAGAIN;
a0d0e21e
LW		 2521 if (result < 0)
2522 RETPUSHUNDEF;
3280af22 2523 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2524 RETPUSHYES;
2525 RETPUSHNO;
2526}
2527
2528PP(pp_ftrexec)
2529{
5ff3f7a4 2530 I32 result;
4e35701f 2531 djSP;
5ff3f7a4 2532#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2533 STRLEN n_a;
5ff3f7a4 2534 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2535 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2536 if (result == 0)
2537 RETPUSHYES;
2538 if (result < 0)
2539 RETPUSHUNDEF;
2540 RETPUSHNO;
22865c03
GS		 2541 }
2542 else
5ff3f7a4
GS		 2543 result = my_stat(ARGS);
2544#else
2545 result = my_stat(ARGS);
2546#endif
22865c03 2547 SPAGAIN;
a0d0e21e
LW		 2548 if (result < 0)
2549 RETPUSHUNDEF;
3280af22 2550 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2551 RETPUSHYES;
2552 RETPUSHNO;
2553}
2554
2555PP(pp_fteread)
2556{
5ff3f7a4 2557 I32 result;
4e35701f 2558 djSP;
5ff3f7a4 2559#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2560 STRLEN n_a;
5ff3f7a4 2561 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2562 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2563 if (result == 0)
2564 RETPUSHYES;
2565 if (result < 0)
2566 RETPUSHUNDEF;
2567 RETPUSHNO;
22865c03
GS		 2568 }
2569 else
5ff3f7a4
GS		 2570 result = my_stat(ARGS);
2571#else
2572 result = my_stat(ARGS);
2573#endif
22865c03 2574 SPAGAIN;
a0d0e21e
LW		 2575 if (result < 0)
2576 RETPUSHUNDEF;
3280af22 2577 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2578 RETPUSHYES;
2579 RETPUSHNO;
2580}
2581
2582PP(pp_ftewrite)
2583{
5ff3f7a4 2584 I32 result;
4e35701f 2585 djSP;
5ff3f7a4 2586#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2587 STRLEN n_a;
5ff3f7a4 2588 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2589 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2590 if (result == 0)
2591 RETPUSHYES;
2592 if (result < 0)
2593 RETPUSHUNDEF;
2594 RETPUSHNO;
22865c03
GS		 2595 }
2596 else
5ff3f7a4
GS		 2597 result = my_stat(ARGS);
2598#else
2599 result = my_stat(ARGS);
2600#endif
22865c03 2601 SPAGAIN;
a0d0e21e
LW		 2602 if (result < 0)
2603 RETPUSHUNDEF;
3280af22 2604 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2605 RETPUSHYES;
2606 RETPUSHNO;
2607}
2608
2609PP(pp_fteexec)
2610{
5ff3f7a4 2611 I32 result;
4e35701f 2612 djSP;
5ff3f7a4 2613#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2614 STRLEN n_a;
5ff3f7a4 2615 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2616 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2617 if (result == 0)
2618 RETPUSHYES;
2619 if (result < 0)
2620 RETPUSHUNDEF;
2621 RETPUSHNO;
22865c03
GS		 2622 }
2623 else
5ff3f7a4
GS		 2624 result = my_stat(ARGS);
2625#else
2626 result = my_stat(ARGS);
2627#endif
22865c03 2628 SPAGAIN;
a0d0e21e
LW		 2629 if (result < 0)
2630 RETPUSHUNDEF;
3280af22 2631 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2632 RETPUSHYES;
2633 RETPUSHNO;
2634}
2635
2636PP(pp_ftis)
2637{
2638 I32 result = my_stat(ARGS);
4e35701f 2639 djSP;
a0d0e21e
LW		 2640 if (result < 0)
2641 RETPUSHUNDEF;
2642 RETPUSHYES;
2643}
2644
2645PP(pp_fteowned)
2646{
2647 return pp_ftrowned(ARGS);
2648}
2649
2650PP(pp_ftrowned)
2651{
2652 I32 result = my_stat(ARGS);
4e35701f 2653 djSP;
a0d0e21e
LW		 2654 if (result < 0)
2655 RETPUSHUNDEF;
533c011a 2656 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2657 RETPUSHYES;
2658 RETPUSHNO;
2659}
2660
2661PP(pp_ftzero)
2662{
2663 I32 result = my_stat(ARGS);
4e35701f 2664 djSP;
a0d0e21e
LW		 2665 if (result < 0)
2666 RETPUSHUNDEF;
3280af22 2667 if (!PL_statcache.st_size)
a0d0e21e
LW		 2668 RETPUSHYES;
2669 RETPUSHNO;
2670}
2671
2672PP(pp_ftsize)
2673{
2674 I32 result = my_stat(ARGS);
4e35701f 2675 djSP; dTARGET;
a0d0e21e
LW		 2676 if (result < 0)
2677 RETPUSHUNDEF;
3280af22 2678 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2679 RETURN;
2680}
2681
2682PP(pp_ftmtime)
2683{
2684 I32 result = my_stat(ARGS);
4e35701f 2685 djSP; dTARGET;
a0d0e21e
LW		 2686 if (result < 0)
2687 RETPUSHUNDEF;
3280af22 2688 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2689 RETURN;
2690}
2691
2692PP(pp_ftatime)
2693{
2694 I32 result = my_stat(ARGS);
4e35701f 2695 djSP; dTARGET;
a0d0e21e
LW		 2696 if (result < 0)
2697 RETPUSHUNDEF;
3280af22 2698 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2699 RETURN;
2700}
2701
2702PP(pp_ftctime)
2703{
2704 I32 result = my_stat(ARGS);
4e35701f 2705 djSP; dTARGET;
a0d0e21e
LW		 2706 if (result < 0)
2707 RETPUSHUNDEF;
3280af22 2708 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2709 RETURN;
2710}
2711
2712PP(pp_ftsock)
2713{
2714 I32 result = my_stat(ARGS);
4e35701f 2715 djSP;
a0d0e21e
LW		 2716 if (result < 0)
2717 RETPUSHUNDEF;
3280af22 2718 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2719 RETPUSHYES;
2720 RETPUSHNO;
2721}
2722
2723PP(pp_ftchr)
2724{
2725 I32 result = my_stat(ARGS);
4e35701f 2726 djSP;
a0d0e21e
LW		 2727 if (result < 0)
2728 RETPUSHUNDEF;
3280af22 2729 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2730 RETPUSHYES;
2731 RETPUSHNO;
2732}
2733
2734PP(pp_ftblk)
2735{
2736 I32 result = my_stat(ARGS);
4e35701f 2737 djSP;
a0d0e21e
LW		 2738 if (result < 0)
2739 RETPUSHUNDEF;
3280af22 2740 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2741 RETPUSHYES;
2742 RETPUSHNO;
2743}
2744
2745PP(pp_ftfile)
2746{
2747 I32 result = my_stat(ARGS);
4e35701f 2748 djSP;
a0d0e21e
LW		 2749 if (result < 0)
2750 RETPUSHUNDEF;
3280af22 2751 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2752 RETPUSHYES;
2753 RETPUSHNO;
2754}
2755
2756PP(pp_ftdir)
2757{
2758 I32 result = my_stat(ARGS);
4e35701f 2759 djSP;
a0d0e21e
LW		 2760 if (result < 0)
2761 RETPUSHUNDEF;
3280af22 2762 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2763 RETPUSHYES;
2764 RETPUSHNO;
2765}
2766
2767PP(pp_ftpipe)
2768{
2769 I32 result = my_stat(ARGS);
4e35701f 2770 djSP;
a0d0e21e
LW		 2771 if (result < 0)
2772 RETPUSHUNDEF;
3280af22 2773 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2774 RETPUSHYES;
2775 RETPUSHNO;
2776}
2777
2778PP(pp_ftlink)
2779{
2780 I32 result = my_lstat(ARGS);
4e35701f 2781 djSP;
a0d0e21e
LW		 2782 if (result < 0)
2783 RETPUSHUNDEF;
3280af22 2784 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2785 RETPUSHYES;
2786 RETPUSHNO;
2787}
2788
2789PP(pp_ftsuid)
2790{
4e35701f 2791 djSP;
a0d0e21e
LW		 2792#ifdef S_ISUID
2793 I32 result = my_stat(ARGS);
2794 SPAGAIN;
2795 if (result < 0)
2796 RETPUSHUNDEF;
3280af22 2797 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2798 RETPUSHYES;
2799#endif
2800 RETPUSHNO;
2801}
2802
2803PP(pp_ftsgid)
2804{
4e35701f 2805 djSP;
a0d0e21e
LW		 2806#ifdef S_ISGID
2807 I32 result = my_stat(ARGS);
2808 SPAGAIN;
2809 if (result < 0)
2810 RETPUSHUNDEF;
3280af22 2811 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2812 RETPUSHYES;
2813#endif
2814 RETPUSHNO;
2815}
2816
2817PP(pp_ftsvtx)
2818{
4e35701f 2819 djSP;
a0d0e21e
LW		 2820#ifdef S_ISVTX
2821 I32 result = my_stat(ARGS);
2822 SPAGAIN;
2823 if (result < 0)
2824 RETPUSHUNDEF;
3280af22 2825 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2826 RETPUSHYES;
2827#endif
2828 RETPUSHNO;
2829}
2830
2831PP(pp_fttty)
2832{
4e35701f 2833 djSP;
a0d0e21e
LW		 2834 int fd;
2835 GV *gv;
fb73857a 2836 char *tmps = Nullch;
2d8e6c8d 2837 STRLEN n_a;
fb73857a 2838
533c011a 2839 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2840 gv = cGVOP->op_gv;
fb73857a 2841 else if (isGV(TOPs))
2842 gv = (GV*)POPs;
2843 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2844 gv = (GV*)SvRV(POPs);
a0d0e21e 2845 else
2d8e6c8d 2846 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2847
a0d0e21e 2848 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2849 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2850 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2851 fd = atoi(tmps);
2852 else
2853 RETPUSHUNDEF;
6ad3d225 2854 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2855 RETPUSHYES;
2856 RETPUSHNO;
2857}
2858
16d20bd9
AD		 2859#if defined(atarist) /* this will work with atariST. Configure will
2860 make guesses for other systems. */
2861# define FILE_base(f) ((f)->_base)
2862# define FILE_ptr(f) ((f)->_ptr)
2863# define FILE_cnt(f) ((f)->_cnt)
2864# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2865#endif
2866
2867PP(pp_fttext)
2868{
4e35701f 2869 djSP;
a0d0e21e
LW		 2870 I32 i;
2871 I32 len;
2872 I32 odd = 0;
2873 STDCHAR tbuf[512];
2874 register STDCHAR *s;
2875 register IO *io;
5f05dabc 2876 register SV *sv;
2877 GV *gv;
2d8e6c8d 2878 STRLEN n_a;
a0d0e21e 2879
533c011a 2880 if (PL_op->op_flags & OPf_REF)
5f05dabc 2881 gv = cGVOP->op_gv;
2882 else if (isGV(TOPs))
2883 gv = (GV*)POPs;
2884 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2885 gv = (GV*)SvRV(POPs);
2886 else
2887 gv = Nullgv;
2888
2889 if (gv) {
a0d0e21e 2890 EXTEND(SP, 1);
3280af22
NIS		 2891 if (gv == PL_defgv) {
2892 if (PL_statgv)
2893 io = GvIO(PL_statgv);
a0d0e21e 2894 else {
3280af22 2895 sv = PL_statname;
a0d0e21e
LW		 2896 goto really_filename;
2897 }
2898 }
2899 else {
3280af22
NIS		 2900 PL_statgv = gv;
2901 PL_laststatval = -1;
2902 sv_setpv(PL_statname, "");
2903 io = GvIO(PL_statgv);
a0d0e21e
LW		 2904 }
2905 if (io && IoIFP(io)) {
5f05dabc 2906 if (! PerlIO_has_base(IoIFP(io)))
2907 DIE("-T and -B not implemented on filehandles");
3280af22
NIS		 2908 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2909 if (PL_laststatval < 0)
5f05dabc 2910 RETPUSHUNDEF;
3280af22 2911 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2912 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2913 RETPUSHNO;
2914 else
2915 RETPUSHYES;
760ac839
LW		 2916 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2917 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2918 if (i != EOF)
760ac839 2919 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2920 }
760ac839 2921 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2922 RETPUSHYES;
760ac839
LW		 2923 len = PerlIO_get_bufsiz(IoIFP(io));
2924 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2925 /* sfio can have large buffers - limit to 512 */
2926 if (len > 512)
2927 len = 512;
a0d0e21e
LW		 2928 }
2929 else {
599cee73
PM		 2930 if (ckWARN(WARN_UNOPENED))
2931 warner(WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2932 GvENAME(cGVOP->op_gv));
748a9306 2933 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2934 RETPUSHUNDEF;
2935 }
2936 }
2937 else {
2938 sv = POPs;
5f05dabc 2939 really_filename:
3280af22
NIS		 2940 PL_statgv = Nullgv;
2941 PL_laststatval = -1;
2d8e6c8d 2942 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2943#ifdef HAS_OPEN3
2d8e6c8d 2944 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2945#else
2d8e6c8d 2946 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW		 2947#endif
2948 if (i < 0) {
2d8e6c8d 2949 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
22c35a8c 2950 warner(WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 2951 RETPUSHUNDEF;
2952 }
3280af22
NIS		 2953 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2954 if (PL_laststatval < 0)
5f05dabc 2955 RETPUSHUNDEF;
6ad3d225
GS		 2956 len = PerlLIO_read(i, tbuf, 512);
2957 (void)PerlLIO_close(i);
a0d0e21e 2958 if (len <= 0) {
533c011a 2959 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2960 RETPUSHNO; /* special case NFS directories */
2961 RETPUSHYES; /* null file is anything */
2962 }
2963 s = tbuf;
2964 }
2965
2966 /* now scan s to look for textiness */
4633a7c4 2967 /* XXX ASCII dependent code */
a0d0e21e
LW		 2968
2969 for (i = 0; i < len; i++, s++) {
2970 if (!*s) { /* null never allowed in text */
2971 odd += len;
2972 break;
2973 }
9d116dd7
JH		 2974#ifdef EBCDIC
2975 else if (!(isPRINT(*s) || isSPACE(*s)))
2976 odd++;
2977#else
a0d0e21e
LW		 2978 else if (*s & 128)
2979 odd++;
2980 else if (*s < 32 &&
2981 *s != '\n' && *s != '\r' && *s != '\b' &&
2982 *s != '\t' && *s != '\f' && *s != 27)
2983 odd++;
9d116dd7 2984#endif
a0d0e21e
LW		 2985 }
2986
533c011a 2987 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2988 RETPUSHNO;
2989 else
2990 RETPUSHYES;
2991}
2992
2993PP(pp_ftbinary)
2994{
2995 return pp_fttext(ARGS);
2996}
2997
2998/* File calls. */
2999
3000PP(pp_chdir)
3001{
4e35701f 3002 djSP; dTARGET;
a0d0e21e
LW		 3003 char *tmps;
3004 SV **svp;
2d8e6c8d 3005 STRLEN n_a;
a0d0e21e
LW		 3006
3007 if (MAXARG < 1)
3008 tmps = Nullch;
3009 else
2d8e6c8d 3010 tmps = POPpx;
a0d0e21e 3011 if (!tmps || !*tmps) {
3280af22 3012 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3013 if (svp)
2d8e6c8d 3014 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3015 }
3016 if (!tmps || !*tmps) {
3280af22 3017 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3018 if (svp)
2d8e6c8d 3019 tmps = SvPV(*svp, n_a);
a0d0e21e 3020 }
491527d0
GS		 3021#ifdef VMS
3022 if (!tmps || !*tmps) {
6b88bc9c 3023 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3024 if (svp)
2d8e6c8d 3025 tmps = SvPV(*svp, n_a);
491527d0
GS		 3026 }
3027#endif
a0d0e21e 3028 TAINT_PROPER("chdir");
6ad3d225 3029 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3030#ifdef VMS
3031 /* Clear the DEFAULT element of ENV so we'll get the new value
3032 * in the future. */
6b88bc9c 3033 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3034#endif
a0d0e21e
LW		 3035 RETURN;
3036}
3037
3038PP(pp_chown)
3039{
4e35701f 3040 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3041 I32 value;
3042#ifdef HAS_CHOWN
533c011a 3043 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3044 SP = MARK;
3045 PUSHi(value);
3046 RETURN;
3047#else
22c35a8c 3048 DIE(PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3049#endif
3050}
3051
3052PP(pp_chroot)
3053{
4e35701f 3054 djSP; dTARGET;
a0d0e21e
LW		 3055 char *tmps;
3056#ifdef HAS_CHROOT
2d8e6c8d
GS		 3057 STRLEN n_a;
3058 tmps = POPpx;
a0d0e21e
LW		 3059 TAINT_PROPER("chroot");
3060 PUSHi( chroot(tmps) >= 0 );
3061 RETURN;
3062#else
22c35a8c 3063 DIE(PL_no_func, "chroot");
a0d0e21e
LW		 3064#endif
3065}
3066
3067PP(pp_unlink)
3068{
4e35701f 3069 djSP; dMARK; dTARGET;
a0d0e21e 3070 I32 value;
533c011a 3071 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3072 SP = MARK;
3073 PUSHi(value);
3074 RETURN;
3075}
3076
3077PP(pp_chmod)
3078{
4e35701f 3079 djSP; dMARK; dTARGET;
a0d0e21e 3080 I32 value;
533c011a 3081 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3082 SP = MARK;
3083 PUSHi(value);
3084 RETURN;
3085}
3086
3087PP(pp_utime)
3088{
4e35701f 3089 djSP; dMARK; dTARGET;
a0d0e21e 3090 I32 value;
533c011a 3091 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3092 SP = MARK;
3093 PUSHi(value);
3094 RETURN;
3095}
3096
3097PP(pp_rename)
3098{
4e35701f 3099 djSP; dTARGET;
a0d0e21e 3100 int anum;
2d8e6c8d 3101 STRLEN n_a;
a0d0e21e 3102
2d8e6c8d
GS		 3103 char *tmps2 = POPpx;
3104 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3105 TAINT_PROPER("rename");
3106#ifdef HAS_RENAME
baed7233 3107 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3108#else
6b88bc9c 3109 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3110 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3111 anum = 1;
3112 else {
3654eb6c 3113 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3114 (void)UNLINK(tmps2);
3115 if (!(anum = link(tmps, tmps2)))
3116 anum = UNLINK(tmps);
3117 }
a0d0e21e
LW		 3118 }
3119#endif
3120 SETi( anum >= 0 );
3121 RETURN;
3122}
3123
3124PP(pp_link)
3125{
4e35701f 3126 djSP; dTARGET;
a0d0e21e 3127#ifdef HAS_LINK
2d8e6c8d
GS		 3128 STRLEN n_a;
3129 char *tmps2 = POPpx;
3130 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3131 TAINT_PROPER("link");
3132 SETi( link(tmps, tmps2) >= 0 );
3133#else
22c35a8c 3134 DIE(PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3135#endif
3136 RETURN;
3137}
3138
3139PP(pp_symlink)
3140{
4e35701f 3141 djSP; dTARGET;
a0d0e21e 3142#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3143 STRLEN n_a;
3144 char *tmps2 = POPpx;
3145 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3146 TAINT_PROPER("symlink");
3147 SETi( symlink(tmps, tmps2) >= 0 );
3148 RETURN;
3149#else
22c35a8c 3150 DIE(PL_no_func, "symlink");
a0d0e21e
LW		 3151#endif
3152}
3153
3154PP(pp_readlink)
3155{
4e35701f 3156 djSP; dTARGET;
a0d0e21e
LW		 3157#ifdef HAS_SYMLINK
3158 char *tmps;
46fc3d4c 3159 char buf[MAXPATHLEN];
a0d0e21e 3160 int len;
2d8e6c8d 3161 STRLEN n_a;
46fc3d4c 3162
fb73857a 3163#ifndef INCOMPLETE_TAINTS
3164 TAINT;
3165#endif
2d8e6c8d 3166 tmps = POPpx;
a0d0e21e
LW		 3167 len = readlink(tmps, buf, sizeof buf);
3168 EXTEND(SP, 1);
3169 if (len < 0)
3170 RETPUSHUNDEF;
3171 PUSHp(buf, len);
3172 RETURN;
3173#else
3174 EXTEND(SP, 1);
3175 RETSETUNDEF; /* just pretend it's a normal file */
3176#endif
3177}
3178
3179#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47
GS		 3180STATIC int
3181dooneliner(char *cmd, char *filename)
a0d0e21e 3182{
1e422769 3183 char *save_filename = filename;
3184 char *cmdline;
3185 char *s;
760ac839 3186 PerlIO *myfp;
1e422769 3187 int anum = 1;
a0d0e21e 3188
1e422769 3189 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3190 strcpy(cmdline, cmd);
3191 strcat(cmdline, " ");
3192 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3193 *s++ = '\\';
3194 *s++ = *filename++;
3195 }
3196 strcpy(s, " 2>&1");
6ad3d225 3197 myfp = PerlProc_popen(cmdline, "r");
1e422769 3198 Safefree(cmdline);
3199
a0d0e21e 3200 if (myfp) {
1e422769 3201 SV *tmpsv = sv_newmortal();
6b88bc9c 3202 /* Need to save/restore 'PL_rs' ?? */
760ac839 3203 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3204 (void)PerlProc_pclose(myfp);
a0d0e21e 3205 if (s != Nullch) {
1e422769 3206 int e;
3207 for (e = 1;
a0d0e21e 3208#ifdef HAS_SYS_ERRLIST
1e422769 3209 e <= sys_nerr
3210#endif
3211 ; e++)
3212 {
3213 /* you don't see this */
3214 char *errmsg =
3215#ifdef HAS_SYS_ERRLIST
3216 sys_errlist[e]
a0d0e21e 3217#else
1e422769 3218 strerror(e)
a0d0e21e 3219#endif
1e422769 3220 ;
3221 if (!errmsg)
3222 break;
3223 if (instr(s, errmsg)) {
3224 SETERRNO(e,0);
3225 return 0;
3226 }
a0d0e21e 3227 }
748a9306 3228 SETERRNO(0,0);
a0d0e21e
LW		 3229#ifndef EACCES
3230#define EACCES EPERM
3231#endif
1e422769 3232 if (instr(s, "cannot make"))
748a9306 3233 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3234 else if (instr(s, "existing file"))
748a9306 3235 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3236 else if (instr(s, "ile exists"))
748a9306 3237 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3238 else if (instr(s, "non-exist"))
748a9306 3239 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3240 else if (instr(s, "does not exist"))
748a9306 3241 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3242 else if (instr(s, "not empty"))
748a9306 3243 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3244 else if (instr(s, "cannot access"))
748a9306 3245 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3246 else
748a9306 3247 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3248 return 0;
3249 }
3250 else { /* some mkdirs return no failure indication */
6b88bc9c 3251 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3252 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3253 anum = !anum;
3254 if (anum)
748a9306 3255 SETERRNO(0,0);
a0d0e21e 3256 else
748a9306 3257 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3258 }
3259 return anum;
3260 }
3261 else
3262 return 0;
3263}
3264#endif
3265
3266PP(pp_mkdir)
3267{
4e35701f 3268 djSP; dTARGET;
a0d0e21e
LW		 3269 int mode = POPi;
3270#ifndef HAS_MKDIR
3271 int oldumask;
3272#endif
2d8e6c8d
GS		 3273 STRLEN n_a;
3274 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3275
3276 TAINT_PROPER("mkdir");
3277#ifdef HAS_MKDIR
6ad3d225 3278 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3279#else
3280 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3281 oldumask = PerlLIO_umask(0);
3282 PerlLIO_umask(oldumask);
3283 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3284#endif
3285 RETURN;
3286}
3287
3288PP(pp_rmdir)
3289{
4e35701f 3290 djSP; dTARGET;
a0d0e21e 3291 char *tmps;
2d8e6c8d 3292 STRLEN n_a;
a0d0e21e 3293
2d8e6c8d 3294 tmps = POPpx;
a0d0e21e
LW		 3295 TAINT_PROPER("rmdir");
3296#ifdef HAS_RMDIR
6ad3d225 3297 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3298#else
3299 XPUSHi( dooneliner("rmdir", tmps) );
3300#endif
3301 RETURN;
3302}
3303
3304/* Directory calls. */
3305
3306PP(pp_open_dir)
3307{
4e35701f 3308 djSP;
a0d0e21e 3309#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3310 STRLEN n_a;
3311 char *dirname = POPpx;
a0d0e21e
LW		 3312 GV *gv = (GV*)POPs;
3313 register IO *io = GvIOn(gv);
3314
3315 if (!io)
3316 goto nope;
3317
3318 if (IoDIRP(io))
6ad3d225
GS		 3319 PerlDir_close(IoDIRP(io));
3320 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3321 goto nope;
3322
3323 RETPUSHYES;
3324nope:
3325 if (!errno)
748a9306 3326 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3327 RETPUSHUNDEF;
3328#else
22c35a8c 3329 DIE(PL_no_dir_func, "opendir");
a0d0e21e
LW		 3330#endif
3331}
3332
3333PP(pp_readdir)
3334{
4e35701f 3335 djSP;
a0d0e21e
LW		 3336#if defined(Direntry_t) && defined(HAS_READDIR)
3337#ifndef I_DIRENT
20ce7b12 3338 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3339#endif
3340 register Direntry_t *dp;
3341 GV *gv = (GV*)POPs;
3342 register IO *io = GvIOn(gv);
fb73857a 3343 SV *sv;
a0d0e21e
LW		 3344
3345 if (!io || !IoDIRP(io))
3346 goto nope;
3347
3348 if (GIMME == G_ARRAY) {
3349 /*SUPPRESS 560*/
6ad3d225 3350 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3351#ifdef DIRNAMLEN
79cb57f6 3352 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3353#else
fb73857a 3354 sv = newSVpv(dp->d_name, 0);
3355#endif
3356#ifndef INCOMPLETE_TAINTS
3357 SvTAINTED_on(sv);
a0d0e21e 3358#endif
fb73857a 3359 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3360 }
3361 }
3362 else {
6ad3d225 3363 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3364 goto nope;
3365#ifdef DIRNAMLEN
79cb57f6 3366 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3367#else
fb73857a 3368 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3369#endif
fb73857a 3370#ifndef INCOMPLETE_TAINTS
3371 SvTAINTED_on(sv);
3372#endif
3373 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3374 }
3375 RETURN;
3376
3377nope:
3378 if (!errno)
748a9306 3379 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3380 if (GIMME == G_ARRAY)
3381 RETURN;
3382 else
3383 RETPUSHUNDEF;
3384#else
22c35a8c 3385 DIE(PL_no_dir_func, "readdir");
a0d0e21e
LW		 3386#endif
3387}
3388
3389PP(pp_telldir)
3390{
4e35701f 3391 djSP; dTARGET;
a0d0e21e 3392#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3393 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3394 /* XXX netbsd still seemed to.
3395 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3396 --JHI 1999-Feb-02 */
3397# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3398 long telldir (DIR *);
dfe9444c 3399# endif
a0d0e21e
LW		 3400 GV *gv = (GV*)POPs;
3401 register IO *io = GvIOn(gv);
3402
3403 if (!io || !IoDIRP(io))
3404 goto nope;
3405
6ad3d225 3406 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3407 RETURN;
3408nope:
3409 if (!errno)
748a9306 3410 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3411 RETPUSHUNDEF;
3412#else
22c35a8c 3413 DIE(PL_no_dir_func, "telldir");
a0d0e21e
LW		 3414#endif
3415}
3416
3417PP(pp_seekdir)
3418{
4e35701f 3419 djSP;
a0d0e21e
LW		 3420#if defined(HAS_SEEKDIR) || defined(seekdir)
3421 long along = POPl;
3422 GV *gv = (GV*)POPs;
3423 register IO *io = GvIOn(gv);
3424
3425 if (!io || !IoDIRP(io))
3426 goto nope;
3427
6ad3d225 3428 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3429
3430 RETPUSHYES;
3431nope:
3432 if (!errno)
748a9306 3433 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3434 RETPUSHUNDEF;
3435#else
22c35a8c 3436 DIE(PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3437#endif
3438}
3439
3440PP(pp_rewinddir)
3441{
4e35701f 3442 djSP;
a0d0e21e
LW		 3443#if defined(HAS_REWINDDIR) || defined(rewinddir)
3444 GV *gv = (GV*)POPs;
3445 register IO *io = GvIOn(gv);
3446
3447 if (!io || !IoDIRP(io))
3448 goto nope;
3449
6ad3d225 3450 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3451 RETPUSHYES;
3452nope:
3453 if (!errno)
748a9306 3454 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3455 RETPUSHUNDEF;
3456#else
22c35a8c 3457 DIE(PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3458#endif
3459}
3460
3461PP(pp_closedir)
3462{
4e35701f 3463 djSP;
a0d0e21e
LW		 3464#if defined(Direntry_t) && defined(HAS_READDIR)
3465 GV *gv = (GV*)POPs;
3466 register IO *io = GvIOn(gv);
3467
3468 if (!io || !IoDIRP(io))
3469 goto nope;
3470
3471#ifdef VOID_CLOSEDIR
6ad3d225 3472 PerlDir_close(IoDIRP(io));
a0d0e21e 3473#else
6ad3d225 3474 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3475 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3476 goto nope;
748a9306 3477 }
a0d0e21e
LW		 3478#endif
3479 IoDIRP(io) = 0;
3480
3481 RETPUSHYES;
3482nope:
3483 if (!errno)
748a9306 3484 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3485 RETPUSHUNDEF;
3486#else
22c35a8c 3487 DIE(PL_no_dir_func, "closedir");
a0d0e21e
LW		 3488#endif
3489}
3490
3491/* Process control. */
3492
3493PP(pp_fork)
3494{
44a8e56a 3495#ifdef HAS_FORK
4e35701f 3496 djSP; dTARGET;
761237fe 3497 Pid_t childpid;
a0d0e21e
LW		 3498 GV *tmpgv;
3499
3500 EXTEND(SP, 1);
45bc9206 3501 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3502 childpid = fork();
3503 if (childpid < 0)
3504 RETSETUNDEF;
3505 if (!childpid) {
3506 /*SUPPRESS 560*/
3507 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3508 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3509 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3510 }
3511 PUSHi(childpid);
3512 RETURN;
3513#else
22c35a8c 3514 DIE(PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3515#endif
3516}
3517
3518PP(pp_wait)
3519{
8736538c 3520#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3521 djSP; dTARGET;
761237fe 3522 Pid_t childpid;
a0d0e21e 3523 int argflags;
a0d0e21e 3524
44a8e56a 3525 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3526 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3527 XPUSHi(childpid);
a0d0e21e
LW		 3528 RETURN;
3529#else
22c35a8c 3530 DIE(PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3531#endif
3532}
3533
3534PP(pp_waitpid)
3535{
8736538c 3536#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3537 djSP; dTARGET;
761237fe 3538 Pid_t childpid;
a0d0e21e
LW		 3539 int optype;
3540 int argflags;
a0d0e21e 3541
a0d0e21e
LW		 3542 optype = POPi;
3543 childpid = TOPi;
3544 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3545 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3546 SETi(childpid);
a0d0e21e
LW		 3547 RETURN;
3548#else
22c35a8c 3549 DIE(PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3550#endif
3551}
3552
3553PP(pp_system)
3554{
4e35701f 3555 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3556 I32 value;
761237fe 3557 Pid_t childpid;
a0d0e21e
LW		 3558 int result;
3559 int status;
ff68c719 3560 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3561 STRLEN n_a;
a0d0e21e 3562
a0d0e21e 3563 if (SP - MARK == 1) {
3280af22 3564 if (PL_tainting) {
2d8e6c8d 3565 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3566 TAINT_ENV();
3567 TAINT_PROPER("system");
3568 }
3569 }
45bc9206 3570 PERL_FLUSHALL_FOR_CHILD;
1e422769 3571#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3572 while ((childpid = vfork()) == -1) {
3573 if (errno != EAGAIN) {
3574 value = -1;
3575 SP = ORIGMARK;
3576 PUSHi(value);
3577 RETURN;
3578 }
3579 sleep(5);
3580 }
3581 if (childpid > 0) {
ff68c719 3582 rsignal_save(SIGINT, SIG_IGN, &ihand);
3583 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3584 do {
3585 result = wait4pid(childpid, &status, 0);
3586 } while (result == -1 && errno == EINTR);
ff68c719 3587 (void)rsignal_restore(SIGINT, &ihand);
3588 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3589 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3590 do_execfree(); /* free any memory child malloced on vfork */
3591 SP = ORIGMARK;
ff0cee69 3592 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3593 RETURN;
3594 }
533c011a 3595 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3596 SV *really = *++MARK;
3597 value = (I32)do_aexec(really, MARK, SP);
3598 }
3599 else if (SP - MARK != 1)
3600 value = (I32)do_aexec(Nullsv, MARK, SP);
3601 else {
2d8e6c8d 3602 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3603 }
6ad3d225 3604 PerlProc__exit(-1);
c3293030 3605#else /* ! FORK or VMS or OS/2 */
911d147d 3606 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3607 SV *really = *++MARK;
4e35701f 3608 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3609 }
3610 else if (SP - MARK != 1)
4e35701f 3611 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3612 else {
2d8e6c8d 3613 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3614 }
f86702cc 3615 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3616 do_execfree();
3617 SP = ORIGMARK;
ff0cee69 3618 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3619#endif /* !FORK or VMS */
3620 RETURN;
3621}
3622
3623PP(pp_exec)
3624{
4e35701f 3625 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3626 I32 value;
2d8e6c8d 3627 STRLEN n_a;
a0d0e21e 3628
45bc9206 3629 PERL_FLUSHALL_FOR_CHILD;
533c011a 3630 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3631 SV *really = *++MARK;
3632 value = (I32)do_aexec(really, MARK, SP);
3633 }
3634 else if (SP - MARK != 1)
3635#ifdef VMS
3636 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3637#else
092bebab
JH		 3638# ifdef __OPEN_VM
3639 {
3640 (void ) do_aspawn(Nullsv, MARK, SP);
3641 value = 0;
3642 }
3643# else
a0d0e21e 3644 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3645# endif
a0d0e21e
LW		 3646#endif
3647 else {
3280af22 3648 if (PL_tainting) {
2d8e6c8d 3649 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3650 TAINT_ENV();
3651 TAINT_PROPER("exec");
3652 }
3653#ifdef VMS
2d8e6c8d 3654 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3655#else
092bebab 3656# ifdef __OPEN_VM
2d8e6c8d 3657 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3658 value = 0;
3659# else