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
missed a file
[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"
864dbfa3 18#define PERL_IN_PP_SYS_C
a0d0e21e
LW		 19#include "perl.h"
20
f1066039
JH		 21#ifdef I_SHADOW
22/* Shadow password support for solaris - pdo@cs.umd.edu
23 * Not just Solaris: at least HP-UX, IRIX, Linux.
24 * the API is from SysV. --jhi */
8c0bfa08
PB		 25#include <shadow.h>
26#endif
27
76c32331 28/* XXX If this causes problems, set i_unistd=undef in the hint file. */
29#ifdef I_UNISTD
30# include <unistd.h>
31#endif
32
8ac85365
NIS		 33#ifdef HAS_SYSCALL
34#ifdef __cplusplus
35extern "C" int syscall(unsigned long,...);
36#endif
37#endif
38
76c32331 39#ifdef I_SYS_WAIT
40# include <sys/wait.h>
41#endif
42
43#ifdef I_SYS_RESOURCE
44# include <sys/resource.h>
16d20bd9 45#endif
a0d0e21e
LW		 46
47#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
48# include <sys/socket.h>
3fd537d4
JH		 49# ifdef I_NETDB
50# include <netdb.h>
51# endif
a0d0e21e
LW		 52# ifndef ENOTSOCK
53# ifdef I_NET_ERRNO
54# include <net/errno.h>
55# endif
56# endif
57#endif
58
59#ifdef HAS_SELECT
60#ifdef I_SYS_SELECT
a0d0e21e
LW		 61#include <sys/select.h>
62#endif
63#endif
a0d0e21e 64
dc45a647
MB		 65/* XXX Configure test needed.
66 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 67 applications, see "extern int errno in perl.h". Creating such
68 a test requires taking into account the differences between
69 compiling multithreaded and singlethreaded ($ccflags et al).
70 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647
MB		 71*/
72#if defined(HOST_NOT_FOUND) && !defined(h_errno)
a0d0e21e
LW		 73extern int h_errno;
74#endif
75
76#ifdef HAS_PASSWD
77# ifdef I_PWD
78# include <pwd.h>
79# else
20ce7b12
GS		 80 struct passwd *getpwnam (char *);
81 struct passwd *getpwuid (Uid_t);
a0d0e21e 82# endif
28e8609d 83# ifdef HAS_GETPWENT
20ce7b12 84 struct passwd *getpwent (void);
28e8609d 85# endif
a0d0e21e
LW		 86#endif
87
88#ifdef HAS_GROUP
89# ifdef I_GRP
90# include <grp.h>
91# else
20ce7b12
GS		 92 struct group *getgrnam (char *);
93 struct group *getgrgid (Gid_t);
a0d0e21e 94# endif
28e8609d 95# ifdef HAS_GETGRENT
20ce7b12 96 struct group *getgrent (void);
28e8609d 97# endif
a0d0e21e
LW		 98#endif
99
100#ifdef I_UTIME
3730b96e 101# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 102# include <sys/utime.h>
103# else
104# include <utime.h>
105# endif
a0d0e21e
LW		 106#endif
107#ifdef I_FCNTL
108#include <fcntl.h>
109#endif
110#ifdef I_SYS_FILE
111#include <sys/file.h>
112#endif
113
54310121 114/* Put this after #includes because fork and vfork prototypes may conflict. */
115#ifndef HAS_VFORK
116# define vfork fork
117#endif
118
d574b85e
CS		 119/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
120#ifndef Sock_size_t
137443ea 121# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 122# define Sock_size_t Size_t
123# else
124# define Sock_size_t int
125# endif
54310121 126#endif
127
cbdc8872 128#ifdef HAS_CHSIZE
cd52b7b2 129# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
130# undef my_chsize
131# endif
6ad3d225 132# define my_chsize PerlLIO_chsize
cbdc8872 133#endif
134
ff68c719 135#ifdef HAS_FLOCK
136# define FLOCK flock
137#else /* no flock() */
138
36477c24 139 /* fcntl.h might not have been included, even if it exists, because
140 the current Configure only sets I_FCNTL if it's needed to pick up
141 the *_OK constants. Make sure it has been included before testing
142 the fcntl() locking constants. */
143# if defined(HAS_FCNTL) && !defined(I_FCNTL)
144# include <fcntl.h>
145# endif
146
ff68c719 147# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
148# define FLOCK fcntl_emulate_flock
149# define FCNTL_EMULATE_FLOCK
150# else /* no flock() or fcntl(F_SETLK,...) */
151# ifdef HAS_LOCKF
152# define FLOCK lockf_emulate_flock
153# define LOCKF_EMULATE_FLOCK
154# endif /* lockf */
155# endif /* no flock() or fcntl(F_SETLK,...) */
156
157# ifdef FLOCK
20ce7b12 158 static int FLOCK (int, int);
ff68c719 159
160 /*
161 * These are the flock() constants. Since this sytems doesn't have
162 * flock(), the values of the constants are probably not available.
163 */
164# ifndef LOCK_SH
165# define LOCK_SH 1
166# endif
167# ifndef LOCK_EX
168# define LOCK_EX 2
169# endif
170# ifndef LOCK_NB
171# define LOCK_NB 4
172# endif
173# ifndef LOCK_UN
174# define LOCK_UN 8
175# endif
176# endif /* emulating flock() */
177
178#endif /* no flock() */
55497cff 179
85ab1d1d
JH		 180#define ZBTLEN 10
181static char zero_but_true[ZBTLEN + 1] = "0 but true";
182
5ff3f7a4
GS		 183#if defined(I_SYS_ACCESS) && !defined(R_OK)
184# include <sys/access.h>
185#endif
186
187#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
188#undef PERL_EFF_ACCESS_W_OK
189#undef PERL_EFF_ACCESS_X_OK
190
191/* F_OK unused: if stat() cannot find it... */
192
193#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 194 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 195# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
196# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
197# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
198#endif
199
200#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS		 201# if defined(I_SYS_SECURITY)
202# include <sys/security.h>
203# endif
c955f117
JH		 204 /* XXX Configure test needed for eaccess */
205# ifdef ACC_SELF
206 /* HP SecureWare */
207# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
208# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
209# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
210# else
211 /* SCO */
212# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
213# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
214# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
215# endif
5ff3f7a4
GS		 216#endif
217
218#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 219 /* AIX */
5ff3f7a4
GS		 220# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
221# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
222# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
223#endif
224
327c3667
GS		 225#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
226 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
227 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 228/* The Hard Way. */
327c3667 229STATIC int
864dbfa3 230emulate_eaccess(pTHX_ const char* path, int mode)
ba106d47 231{
5ff3f7a4
GS		 232 Uid_t ruid = getuid();
233 Uid_t euid = geteuid();
234 Gid_t rgid = getgid();
235 Gid_t egid = getegid();
236 int res;
237
238 MUTEX_LOCK(&PL_cred_mutex);
239#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
85ab1d1d 240 croak("switching effective uid is not implemented");
5ff3f7a4
GS		 241#else
242#ifdef HAS_SETREUID
243 if (setreuid(euid, ruid))
244#else
245#ifdef HAS_SETRESUID
246 if (setresuid(euid, ruid, (Uid_t)-1))
247#endif
248#endif
85ab1d1d 249 croak("entering effective uid failed");
5ff3f7a4
GS		 250#endif
251
252#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
85ab1d1d 253 croak("switching effective gid is not implemented");
5ff3f7a4
GS		 254#else
255#ifdef HAS_SETREGID
256 if (setregid(egid, rgid))
257#else
258#ifdef HAS_SETRESGID
259 if (setresgid(egid, rgid, (Gid_t)-1))
260#endif
261#endif
85ab1d1d 262 croak("entering effective gid failed");
5ff3f7a4
GS		 263#endif
264
265 res = access(path, mode);
266
267#ifdef HAS_SETREUID
268 if (setreuid(ruid, euid))
269#else
270#ifdef HAS_SETRESUID
271 if (setresuid(ruid, euid, (Uid_t)-1))
272#endif
273#endif
85ab1d1d 274 croak("leaving effective uid failed");
5ff3f7a4
GS		 275
276#ifdef HAS_SETREGID
277 if (setregid(rgid, egid))
278#else
279#ifdef HAS_SETRESGID
280 if (setresgid(rgid, egid, (Gid_t)-1))
281#endif
282#endif
85ab1d1d 283 croak("leaving effective gid failed");
5ff3f7a4
GS		 284 MUTEX_UNLOCK(&PL_cred_mutex);
285
286 return res;
287}
288# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
289# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
290# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
291#endif
292
293#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 294STATIC int
864dbfa3 295emulate_eaccess(pTHX_ const char* path, int mode)
ba106d47 296{
85ab1d1d 297 croak("switching effective uid is not implemented");
5ff3f7a4
GS		 298 /*NOTREACHED*/
299 return -1;
300}
301#endif
302
a0d0e21e
LW		 303PP(pp_backtick)
304{
4e35701f 305 djSP; dTARGET;
760ac839 306 PerlIO *fp;
2d8e6c8d
GS		 307 STRLEN n_a;
308 char *tmps = POPpx;
54310121 309 I32 gimme = GIMME_V;
310
a0d0e21e 311 TAINT_PROPER("``");
6ad3d225 312 fp = PerlProc_popen(tmps, "r");
a0d0e21e 313 if (fp) {
54310121 314 if (gimme == G_VOID) {
96827780
MB		 315 char tmpbuf[256];
316 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 317 /*SUPPRESS 530*/
318 ;
319 }
320 else if (gimme == G_SCALAR) {
aa689395 321 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 322 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
323 /*SUPPRESS 530*/
324 ;
325 XPUSHs(TARG);
aa689395 326 SvTAINTED_on(TARG);
a0d0e21e
LW		 327 }
328 else {
329 SV *sv;
330
331 for (;;) {
8d6dde3e 332 sv = NEWSV(56, 79);
a0d0e21e
LW		 333 if (sv_gets(sv, fp, 0) == Nullch) {
334 SvREFCNT_dec(sv);
335 break;
336 }
337 XPUSHs(sv_2mortal(sv));
338 if (SvLEN(sv) - SvCUR(sv) > 20) {
339 SvLEN_set(sv, SvCUR(sv)+1);
340 Renew(SvPVX(sv), SvLEN(sv), char);
341 }
aa689395 342 SvTAINTED_on(sv);
a0d0e21e
LW		 343 }
344 }
6ad3d225 345 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 346 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 347 }
348 else {
f86702cc 349 STATUS_NATIVE_SET(-1);
54310121 350 if (gimme == G_SCALAR)
a0d0e21e
LW		 351 RETPUSHUNDEF;
352 }
353
354 RETURN;
355}
356
357PP(pp_glob)
358{
359 OP *result;
f5284f61
IZ		 360 tryAMAGICunTARGET(iter, -1);
361
a0d0e21e 362 ENTER;
a0d0e21e 363
c90c0ff4 364#ifndef VMS
3280af22 365 if (PL_tainting) {
7bac28a0 366 /*
367 * The external globbing program may use things we can't control,
368 * so for security reasons we must assume the worst.
369 */
370 TAINT;
22c35a8c 371 taint_proper(PL_no_security, "glob");
7bac28a0 372 }
c90c0ff4 373#endif /* !VMS */
7bac28a0 374
3280af22
NIS		 375 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
376 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 377
3280af22 378 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 379 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 380#ifndef DOSISH
381#ifndef CSH
6b88bc9c 382 *SvPVX(PL_rs) = '\n';
a0d0e21e 383#endif /* !CSH */
55497cff 384#endif /* !DOSISH */
c07a80fd 385
a0d0e21e
LW		 386 result = do_readline();
387 LEAVE;
388 return result;
389}
390
15e52e56 391#if 0 /* XXX never used! */
a0d0e21e
LW		 392PP(pp_indread)
393{
2d8e6c8d
GS		 394 STRLEN n_a;
395 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 396 return do_readline();
397}
15e52e56 398#endif
a0d0e21e
LW		 399
400PP(pp_rcatline)
401{
3280af22 402 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW		 403 return do_readline();
404}
405
406PP(pp_warn)
407{
4e35701f 408 djSP; dMARK;
06bf62c7 409 SV *tmpsv;
a0d0e21e 410 char *tmps;
06bf62c7 411 STRLEN len;
a0d0e21e
LW		 412 if (SP - MARK != 1) {
413 dTARGET;
3280af22 414 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 415 tmpsv = TARG;
a0d0e21e
LW		 416 SP = MARK + 1;
417 }
418 else {
06bf62c7 419 tmpsv = TOPs;
a0d0e21e 420 }
06bf62c7
GS		 421 tmps = SvPV(tmpsv, len);
422 if (!tmps || !len) {
4e6ea2c3
GS		 423 SV *error = ERRSV;
424 (void)SvUPGRADE(error, SVt_PV);
425 if (SvPOK(error) && SvCUR(error))
426 sv_catpv(error, "\t...caught");
06bf62c7
GS		 427 tmpsv = error;
428 tmps = SvPV(tmpsv, len);
a0d0e21e 429 }
06bf62c7
GS		 430 if (!tmps || !len)
431 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
432
433 warn("%_", tmpsv);
a0d0e21e
LW		 434 RETSETYES;
435}
436
437PP(pp_die)
438{
4e35701f 439 djSP; dMARK;
a0d0e21e 440 char *tmps;
06bf62c7
GS		 441 SV *tmpsv;
442 STRLEN len;
443 bool multiarg = 0;
a0d0e21e
LW		 444 if (SP - MARK != 1) {
445 dTARGET;
3280af22 446 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 447 tmpsv = TARG;
448 tmps = SvPV(tmpsv, len);
449 multiarg = 1;
a0d0e21e
LW		 450 SP = MARK + 1;
451 }
452 else {
4e6ea2c3 453 tmpsv = TOPs;
06bf62c7 454 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 455 }
06bf62c7 456 if (!tmps || !len) {
4e6ea2c3
GS		 457 SV *error = ERRSV;
458 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 459 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
460 if (!multiarg)
4e6ea2c3 461 SvSetSV(error,tmpsv);
06bf62c7 462 else if (sv_isobject(error)) {
05423cc9
GS		 463 HV *stash = SvSTASH(SvRV(error));
464 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
465 if (gv) {
3280af22
NIS		 466 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
467 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS		 468 EXTEND(SP, 3);
469 PUSHMARK(SP);
470 PUSHs(error);
471 PUSHs(file);
472 PUSHs(line);
473 PUTBACK;
864dbfa3
GS		 474 call_sv((SV*)GvCV(gv),
475 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 476 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 477 }
478 }
06bf62c7 479 DIE(Nullch);
4e6ea2c3
GS		 480 }
481 else {
482 if (SvPOK(error) && SvCUR(error))
483 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 484 tmpsv = error;
485 tmps = SvPV(tmpsv, len);
4e6ea2c3 486 }
a0d0e21e 487 }
06bf62c7
GS		 488 if (!tmps || !len)
489 tmpsv = sv_2mortal(newSVpvn("Died", 4));
490
491 DIE("%_", tmpsv);
a0d0e21e
LW		 492}
493
494/* I/O. */
495
496PP(pp_open)
497{
4e35701f 498 djSP; dTARGET;
a0d0e21e
LW		 499 GV *gv;
500 SV *sv;
501 char *tmps;
502 STRLEN len;
4592e6ca 503 MAGIC *mg;
a0d0e21e
LW		 504
505 if (MAXARG > 1)
506 sv = POPs;
5f05dabc 507 if (!isGV(TOPs))
22c35a8c 508 DIE(PL_no_usym, "filehandle");
5f05dabc 509 if (MAXARG <= 1)
510 sv = GvSV(TOPs);
a0d0e21e 511 gv = (GV*)POPs;
5f05dabc 512 if (!isGV(gv))
22c35a8c 513 DIE(PL_no_usym, "filehandle");
36477c24 514 if (GvIOp(gv))
515 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea
NIS		 516
517#if 0 /* no undef means tmpfile() yet */
3eb568f1
NIS		 518 if (sv == &PL_sv_undef) {
519#ifdef PerlIO
520 PerlIO *fp = PerlIO_tmpfile();
521#else
522 PerlIO *fp = tmpfile();
523#endif
524 if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
525 PUSHi( (I32)PL_forkprocess );
526 else
527 RETPUSHUNDEF;
528 RETURN;
529 }
853846ea
NIS		 530#endif /* no undef means tmpfile() yet */
531
4592e6ca
NIS		 532
533 if (mg = SvTIED_mg((SV*)gv, 'q')) {
534 PUSHMARK(SP);
535 XPUSHs(SvTIED_obj((SV*)gv, mg));
536 XPUSHs(sv);
537 PUTBACK;
538 ENTER;
864dbfa3 539 call_method("OPEN", G_SCALAR);
4592e6ca
NIS		 540 LEAVE;
541 SPAGAIN;
542 RETURN;
543 }
544
a0d0e21e 545 tmps = SvPV(sv, len);
9d116dd7 546 if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
3280af22
NIS		 547 PUSHi( (I32)PL_forkprocess );
548 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 549 PUSHi(0);
550 else
551 RETPUSHUNDEF;
552 RETURN;
553}
554
555PP(pp_close)
556{
4e35701f 557 djSP;
a0d0e21e 558 GV *gv;
1d603a67 559 MAGIC *mg;
a0d0e21e
LW		 560
561 if (MAXARG == 0)
3280af22 562 gv = PL_defoutgv;
a0d0e21e
LW		 563 else
564 gv = (GV*)POPs;
1d603a67 565
33c27489 566 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 567 PUSHMARK(SP);
33c27489 568 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 569 PUTBACK;
570 ENTER;
864dbfa3 571 call_method("CLOSE", G_SCALAR);
1d603a67
GB		 572 LEAVE;
573 SPAGAIN;
574 RETURN;
575 }
a0d0e21e 576 EXTEND(SP, 1);
54310121 577 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 578 RETURN;
579}
580
581PP(pp_pipe_op)
582{
4e35701f 583 djSP;
a0d0e21e
LW		 584#ifdef HAS_PIPE
585 GV *rgv;
586 GV *wgv;
587 register IO *rstio;
588 register IO *wstio;
589 int fd[2];
590
591 wgv = (GV*)POPs;
592 rgv = (GV*)POPs;
593
594 if (!rgv || !wgv)
595 goto badexit;
596
4633a7c4 597 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
22c35a8c 598 DIE(PL_no_usym, "filehandle");
a0d0e21e
LW		 599 rstio = GvIOn(rgv);
600 wstio = GvIOn(wgv);
601
602 if (IoIFP(rstio))
603 do_close(rgv, FALSE);
604 if (IoIFP(wstio))
605 do_close(wgv, FALSE);
606
6ad3d225 607 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 608 goto badexit;
609
760ac839
LW		 610 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
611 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 612 IoIFP(wstio) = IoOFP(wstio);
613 IoTYPE(rstio) = '<';
614 IoTYPE(wstio) = '>';
615
616 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 617 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 618 else PerlLIO_close(fd[0]);
760ac839 619 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 620 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 621 goto badexit;
622 }
4771b018
GS		 623#if defined(HAS_FCNTL) && defined(F_SETFD)
624 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
625 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
626#endif
a0d0e21e
LW		 627 RETPUSHYES;
628
629badexit:
630 RETPUSHUNDEF;
631#else
22c35a8c 632 DIE(PL_no_func, "pipe");
a0d0e21e
LW		 633#endif
634}
635
636PP(pp_fileno)
637{
4e35701f 638 djSP; dTARGET;
a0d0e21e
LW		 639 GV *gv;
640 IO *io;
760ac839 641 PerlIO *fp;
4592e6ca
NIS		 642 MAGIC *mg;
643
a0d0e21e
LW		 644 if (MAXARG < 1)
645 RETPUSHUNDEF;
646 gv = (GV*)POPs;
4592e6ca
NIS		 647
648 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
649 PUSHMARK(SP);
650 XPUSHs(SvTIED_obj((SV*)gv, mg));
651 PUTBACK;
652 ENTER;
864dbfa3 653 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 654 LEAVE;
655 SPAGAIN;
656 RETURN;
657 }
658
a0d0e21e
LW		 659 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
660 RETPUSHUNDEF;
760ac839 661 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 662 RETURN;
663}
664
665PP(pp_umask)
666{
4e35701f 667 djSP; dTARGET;
761237fe 668 Mode_t anum;
a0d0e21e
LW		 669
670#ifdef HAS_UMASK
671 if (MAXARG < 1) {
6ad3d225
GS		 672 anum = PerlLIO_umask(0);
673 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 674 }
675 else
6ad3d225 676 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 677 TAINT_PROPER("umask");
678 XPUSHi(anum);
679#else
eec2d3df
GS		 680 /* Only DIE if trying to restrict permissions on `user' (self).
681 * Otherwise it's harmless and more useful to just return undef
682 * since 'group' and 'other' concepts probably don't exist here. */
683 if (MAXARG >= 1 && (POPi & 0700))
684 DIE("umask not implemented");
6b88bc9c 685 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 686#endif
687 RETURN;
688}
689
690PP(pp_binmode)
691{
4e35701f 692 djSP;
a0d0e21e
LW		 693 GV *gv;
694 IO *io;
760ac839 695 PerlIO *fp;
4592e6ca 696 MAGIC *mg;
a0d0e21e
LW		 697
698 if (MAXARG < 1)
699 RETPUSHUNDEF;
700
4592e6ca
NIS		 701 gv = (GV*)POPs;
702
703 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
704 PUSHMARK(SP);
705 XPUSHs(SvTIED_obj((SV*)gv, mg));
706 PUTBACK;
707 ENTER;
864dbfa3 708 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS		 709 LEAVE;
710 SPAGAIN;
711 RETURN;
712 }
a0d0e21e
LW		 713
714 EXTEND(SP, 1);
715 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 716 RETPUSHUNDEF;
a0d0e21e 717
491527d0 718 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW		 719 RETPUSHYES;
720 else
721 RETPUSHUNDEF;
a0d0e21e
LW		 722}
723
b8e3bfaf 724
a0d0e21e
LW		 725PP(pp_tie)
726{
4e35701f 727 djSP;
e336de0d 728 dMARK;
a0d0e21e
LW		 729 SV *varsv;
730 HV* stash;
731 GV *gv;
a0d0e21e 732 SV *sv;
3280af22 733 I32 markoff = MARK - PL_stack_base;
a0d0e21e 734 char *methname;
6b05c17a 735 int how = 'P';
e336de0d 736 U32 items;
2d8e6c8d 737 STRLEN n_a;
a0d0e21e 738
e336de0d 739 varsv = *++MARK;
6b05c17a
NIS		 740 switch(SvTYPE(varsv)) {
741 case SVt_PVHV:
742 methname = "TIEHASH";
743 break;
744 case SVt_PVAV:
745 methname = "TIEARRAY";
746 break;
747 case SVt_PVGV:
748 methname = "TIEHANDLE";
749 how = 'q';
750 break;
751 default:
752 methname = "TIESCALAR";
753 how = 'q';
754 break;
755 }
e336de0d
GS		 756 items = SP - MARK++;
757 if (sv_isobject(*MARK)) {
6b05c17a 758 ENTER;
e788e7d3 759 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 760 PUSHMARK(SP);
761 EXTEND(SP,items);
762 while (items--)
763 PUSHs(*MARK++);
764 PUTBACK;
864dbfa3 765 call_method(methname, G_SCALAR);
6b05c17a
NIS		 766 }
767 else {
864dbfa3 768 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 769 * perhaps to get different error message ?
770 */
e336de0d 771 stash = gv_stashsv(*MARK, FALSE);
6b05c17a
NIS		 772 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
773 DIE("Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 774 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 775 }
776 ENTER;
e788e7d3 777 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 778 PUSHMARK(SP);
779 EXTEND(SP,items);
780 while (items--)
781 PUSHs(*MARK++);
782 PUTBACK;
864dbfa3 783 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 784 }
a0d0e21e
LW		 785 SPAGAIN;
786
787 sv = TOPs;
d3acc0f7 788 POPSTACK;
a0d0e21e 789 if (sv_isobject(sv)) {
33c27489
GS		 790 sv_unmagic(varsv, how);
791 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW		 792 }
793 LEAVE;
3280af22 794 SP = PL_stack_base + markoff;
a0d0e21e
LW		 795 PUSHs(sv);
796 RETURN;
797}
798
799PP(pp_untie)
800{
4e35701f 801 djSP;
33c27489
GS		 802 SV *sv = POPs;
803 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 804
599cee73 805 if (ckWARN(WARN_UNTIE)) {
cbdc8872 806 MAGIC * mg ;
33c27489 807 if (mg = SvTIED_mg(sv, how)) {
cbdc8872 808 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
599cee73
PM		 809 warner(WARN_UNTIE,
810 "untie attempted while %lu inner references still exist",
811 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 812 }
813 }
814
33c27489 815 sv_unmagic(sv, how);
55497cff 816 RETPUSHYES;
a0d0e21e
LW		 817}
818
c07a80fd 819PP(pp_tied)
820{
4e35701f 821 djSP;
33c27489
GS		 822 SV *sv = POPs;
823 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
824 MAGIC *mg;
c07a80fd 825
33c27489
GS		 826 if (mg = SvTIED_mg(sv, how)) {
827 SV *osv = SvTIED_obj(sv, mg);
828 if (osv == mg->mg_obj)
829 osv = sv_mortalcopy(osv);
830 PUSHs(osv);
831 RETURN;
c07a80fd 832 }
c07a80fd 833 RETPUSHUNDEF;
834}
835
a0d0e21e
LW		 836PP(pp_dbmopen)
837{
4e35701f 838 djSP;
a0d0e21e
LW		 839 HV *hv;
840 dPOPPOPssrl;
841 HV* stash;
842 GV *gv;
a0d0e21e
LW		 843 SV *sv;
844
845 hv = (HV*)POPs;
846
3280af22 847 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 848 sv_setpv(sv, "AnyDBM_File");
849 stash = gv_stashsv(sv, FALSE);
8ebc5c01 850 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 851 PUTBACK;
864dbfa3 852 require_pv("AnyDBM_File.pm");
a0d0e21e 853 SPAGAIN;
8ebc5c01 854 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
a0d0e21e
LW		 855 DIE("No dbm on this machine");
856 }
857
57d3b86d 858 ENTER;
924508f0 859 PUSHMARK(SP);
6b05c17a 860
924508f0 861 EXTEND(SP, 5);
a0d0e21e
LW		 862 PUSHs(sv);
863 PUSHs(left);
864 if (SvIV(right))
865 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
866 else
867 PUSHs(sv_2mortal(newSViv(O_RDWR)));
868 PUSHs(right);
57d3b86d 869 PUTBACK;
864dbfa3 870 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 871 SPAGAIN;
872
873 if (!sv_isobject(TOPs)) {
924508f0
GS		 874 SP--;
875 PUSHMARK(SP);
a0d0e21e
LW		 876 PUSHs(sv);
877 PUSHs(left);
878 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
879 PUSHs(right);
a0d0e21e 880 PUTBACK;
864dbfa3 881 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 882 SPAGAIN;
883 }
884
6b05c17a
NIS		 885 if (sv_isobject(TOPs)) {
886 sv_unmagic((SV *) hv, 'P');
a0d0e21e 887 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 888 }
a0d0e21e
LW		 889 LEAVE;
890 RETURN;
891}
892
893PP(pp_dbmclose)
894{
895 return pp_untie(ARGS);
896}
897
898PP(pp_sselect)
899{
4e35701f 900 djSP; dTARGET;
a0d0e21e
LW		 901#ifdef HAS_SELECT
902 register I32 i;
903 register I32 j;
904 register char *s;
905 register SV *sv;
906 double value;
907 I32 maxlen = 0;
908 I32 nfound;
909 struct timeval timebuf;
910 struct timeval *tbuf = &timebuf;
911 I32 growsize;
912 char *fd_sets[4];
2d8e6c8d 913 STRLEN n_a;
a0d0e21e
LW		 914#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
915 I32 masksize;
916 I32 offset;
917 I32 k;
918
919# if BYTEORDER & 0xf0000
920# define ORDERBYTE (0x88888888 - BYTEORDER)
921# else
922# define ORDERBYTE (0x4444 - BYTEORDER)
923# endif
924
925#endif
926
927 SP -= 4;
928 for (i = 1; i <= 3; i++) {
929 if (!SvPOK(SP[i]))
930 continue;
931 j = SvCUR(SP[i]);
932 if (maxlen < j)
933 maxlen = j;
934 }
935
5ff3f7a4 936/* little endians can use vecs directly */
a0d0e21e 937#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 938# if SELECT_MIN_BITS > 1
f2da832e
JH		 939 /* If SELECT_MIN_BITS is greater than one we most probably will want
940 * to align the sizes with SELECT_MIN_BITS/8 because for example
941 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W		 942 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
943 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 944 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 945# else
4633a7c4 946 growsize = sizeof(fd_set);
5ff3f7a4
GS		 947# endif
948# else
949# ifdef NFDBITS
a0d0e21e 950
5ff3f7a4
GS		 951# ifndef NBBY
952# define NBBY 8
953# endif
a0d0e21e
LW		 954
955 masksize = NFDBITS / NBBY;
5ff3f7a4 956# else
a0d0e21e 957 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 958# endif
a0d0e21e
LW		 959 growsize = maxlen + (masksize - (maxlen % masksize));
960 Zero(&fd_sets[0], 4, char*);
961#endif
962
963 sv = SP[4];
964 if (SvOK(sv)) {
965 value = SvNV(sv);
966 if (value < 0.0)
967 value = 0.0;
968 timebuf.tv_sec = (long)value;
969 value -= (double)timebuf.tv_sec;
970 timebuf.tv_usec = (long)(value * 1000000.0);
971 }
972 else
973 tbuf = Null(struct timeval*);
974
975 for (i = 1; i <= 3; i++) {
976 sv = SP[i];
977 if (!SvOK(sv)) {
978 fd_sets[i] = 0;
979 continue;
980 }
981 else if (!SvPOK(sv))
2d8e6c8d 982 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 983 j = SvLEN(sv);
984 if (j < growsize) {
985 Sv_Grow(sv, growsize);
a0d0e21e 986 }
c07a80fd 987 j = SvCUR(sv);
988 s = SvPVX(sv) + j;
989 while (++j <= growsize) {
990 *s++ = '\0';
991 }
992
a0d0e21e
LW		 993#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
994 s = SvPVX(sv);
995 New(403, fd_sets[i], growsize, char);
996 for (offset = 0; offset < growsize; offset += masksize) {
997 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
998 fd_sets[i][j+offset] = s[(k % masksize) + offset];
999 }
1000#else
1001 fd_sets[i] = SvPVX(sv);
1002#endif
1003 }
1004
6ad3d225 1005 nfound = PerlSock_select(
a0d0e21e
LW		 1006 maxlen * 8,
1007 (Select_fd_set_t) fd_sets[1],
1008 (Select_fd_set_t) fd_sets[2],
1009 (Select_fd_set_t) fd_sets[3],
1010 tbuf);
1011 for (i = 1; i <= 3; i++) {
1012 if (fd_sets[i]) {
1013 sv = SP[i];
1014#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1015 s = SvPVX(sv);
1016 for (offset = 0; offset < growsize; offset += masksize) {
1017 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1018 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1019 }
1020 Safefree(fd_sets[i]);
1021#endif
1022 SvSETMAGIC(sv);
1023 }
1024 }
1025
1026 PUSHi(nfound);
1027 if (GIMME == G_ARRAY && tbuf) {
1028 value = (double)(timebuf.tv_sec) +
1029 (double)(timebuf.tv_usec) / 1000000.0;
3280af22 1030 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1031 sv_setnv(sv, value);
1032 }
1033 RETURN;
1034#else
1035 DIE("select not implemented");
1036#endif
1037}
1038
4633a7c4 1039void
864dbfa3 1040Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1041{
11343788 1042 dTHR;
4633a7c4
LW		 1043 if (gv)
1044 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1045 if (PL_defoutgv)
1046 SvREFCNT_dec(PL_defoutgv);
1047 PL_defoutgv = gv;
4633a7c4
LW		 1048}
1049
a0d0e21e
LW		 1050PP(pp_select)
1051{
4e35701f 1052 djSP; dTARGET;
4633a7c4
LW		 1053 GV *newdefout, *egv;
1054 HV *hv;
1055
533c011a 1056 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1057
3280af22 1058 egv = GvEGV(PL_defoutgv);
4633a7c4 1059 if (!egv)
3280af22 1060 egv = PL_defoutgv;
4633a7c4
LW		 1061 hv = GvSTASH(egv);
1062 if (! hv)
3280af22 1063 XPUSHs(&PL_sv_undef);
4633a7c4 1064 else {
cbdc8872 1065 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1066 if (gvp && *gvp == egv) {
3280af22 1067 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc 1068 XPUSHTARG;
1069 }
1070 else {
1071 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1072 }
4633a7c4
LW		 1073 }
1074
1075 if (newdefout) {
ded8aa31
GS		 1076 if (!GvIO(newdefout))
1077 gv_IOadd(newdefout);
4633a7c4
LW		 1078 setdefout(newdefout);
1079 }
1080
a0d0e21e
LW		 1081 RETURN;
1082}
1083
1084PP(pp_getc)
1085{
4e35701f 1086 djSP; dTARGET;
a0d0e21e 1087 GV *gv;
2ae324a7 1088 MAGIC *mg;
a0d0e21e
LW		 1089
1090 if (MAXARG <= 0)
3280af22 1091 gv = PL_stdingv;
a0d0e21e
LW		 1092 else
1093 gv = (GV*)POPs;
1094 if (!gv)
3280af22 1095 gv = PL_argvgv;
2ae324a7 1096
33c27489 1097 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1098 I32 gimme = GIMME_V;
2ae324a7 1099 PUSHMARK(SP);
33c27489 1100 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1101 PUTBACK;
1102 ENTER;
864dbfa3 1103 call_method("GETC", gimme);
2ae324a7 1104 LEAVE;
1105 SPAGAIN;
54310121 1106 if (gimme == G_SCALAR)
1107 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1108 RETURN;
1109 }
9bc64814 1110 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1111 RETPUSHUNDEF;
bbce6d69 1112 TAINT;
a0d0e21e 1113 sv_setpv(TARG, " ");
9bc64814 1114 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1115 PUSHTARG;
1116 RETURN;
1117}
1118
1119PP(pp_read)
1120{
1121 return pp_sysread(ARGS);
1122}
1123
76e3520e 1124STATIC OP *
864dbfa3 1125doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1126{
11343788 1127 dTHR;
c09156bb 1128 register PERL_CONTEXT *cx;
54310121 1129 I32 gimme = GIMME_V;
a0d0e21e
LW		 1130 AV* padlist = CvPADLIST(cv);
1131 SV** svp = AvARRAY(padlist);
1132
1133 ENTER;
1134 SAVETMPS;
1135
1136 push_return(retop);
3280af22 1137 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1138 PUSHFORMAT(cx);
3280af22
NIS		 1139 SAVESPTR(PL_curpad);
1140 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1141
4633a7c4 1142 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1143 return CvSTART(cv);
1144}
1145
1146PP(pp_enterwrite)
1147{
4e35701f 1148 djSP;
a0d0e21e
LW		 1149 register GV *gv;
1150 register IO *io;
1151 GV *fgv;
1152 CV *cv;
1153
1154 if (MAXARG == 0)
3280af22 1155 gv = PL_defoutgv;
a0d0e21e
LW		 1156 else {
1157 gv = (GV*)POPs;
1158 if (!gv)
3280af22 1159 gv = PL_defoutgv;
a0d0e21e
LW		 1160 }
1161 EXTEND(SP, 1);
1162 io = GvIO(gv);
1163 if (!io) {
1164 RETPUSHNO;
1165 }
1166 if (IoFMT_GV(io))
1167 fgv = IoFMT_GV(io);
1168 else
1169 fgv = gv;
1170
1171 cv = GvFORM(fgv);
a0d0e21e
LW		 1172 if (!cv) {
1173 if (fgv) {
748a9306 1174 SV *tmpsv = sv_newmortal();
aac0dd9a 1175 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 1176 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW		 1177 }
1178 DIE("Not a format reference");
1179 }
44a8e56a 1180 if (CvCLONE(cv))
1181 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1182
44a8e56a 1183 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1184 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1185}
1186
1187PP(pp_leavewrite)
1188{
4e35701f 1189 djSP;
a0d0e21e
LW		 1190 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1191 register IO *io = GvIOp(gv);
760ac839
LW		 1192 PerlIO *ofp = IoOFP(io);
1193 PerlIO *fp;
a0d0e21e
LW		 1194 SV **newsp;
1195 I32 gimme;
c09156bb 1196 register PERL_CONTEXT *cx;
a0d0e21e 1197
760ac839 1198 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1199 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1200 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1201 PL_formtarget != PL_toptarget)
a0d0e21e 1202 {
4633a7c4
LW		 1203 GV *fgv;
1204 CV *cv;
a0d0e21e
LW		 1205 if (!IoTOP_GV(io)) {
1206 GV *topgv;
46fc3d4c 1207 SV *topname;
a0d0e21e
LW		 1208
1209 if (!IoTOP_NAME(io)) {
1210 if (!IoFMT_NAME(io))
1211 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c 1212 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1213 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1214 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1215 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1216 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1217 else
1218 IoTOP_NAME(io) = savepv("top");
1219 }
1220 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1221 if (!topgv || !GvFORM(topgv)) {
1222 IoLINES_LEFT(io) = 100000000;
1223 goto forget_top;
1224 }
1225 IoTOP_GV(io) = topgv;
1226 }
748a9306
LW		 1227 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1228 I32 lines = IoLINES_LEFT(io);
3280af22 1229 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1230 if (lines <= 0) /* Yow, header didn't even fit!!! */
1231 goto forget_top;
748a9306
LW		 1232 while (lines-- > 0) {
1233 s = strchr(s, '\n');
1234 if (!s)
1235 break;
1236 s++;
1237 }
1238 if (s) {
3280af22
NIS		 1239 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1240 sv_chop(PL_formtarget, s);
1241 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1242 }
1243 }
a0d0e21e 1244 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1245 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1246 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1247 IoPAGE(io)++;
3280af22 1248 PL_formtarget = PL_toptarget;
748a9306 1249 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1250 fgv = IoTOP_GV(io);
1251 if (!fgv)
1252 DIE("bad top format reference");
1253 cv = GvFORM(fgv);
1254 if (!cv) {
1255 SV *tmpsv = sv_newmortal();
aac0dd9a 1256 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW		 1257 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1258 }
44a8e56a 1259 if (CvCLONE(cv))
1260 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1261 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1262 }
1263
1264 forget_top:
3280af22 1265 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1266 POPFORMAT(cx);
1267 LEAVE;
1268
1269 fp = IoOFP(io);
1270 if (!fp) {
599cee73 1271 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
a0d0e21e 1272 if (IoIFP(io))
599cee73
PM		 1273 warner(WARN_IO, "Filehandle only opened for input");
1274 else if (ckWARN(WARN_CLOSED))
1275 warner(WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1276 }
3280af22 1277 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1278 }
1279 else {
3280af22 1280 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73
PM		 1281 if (ckWARN(WARN_IO))
1282 warner(WARN_IO, "page overflow");
a0d0e21e 1283 }
3280af22 1284 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1285 PerlIO_error(fp))
3280af22 1286 PUSHs(&PL_sv_no);
a0d0e21e 1287 else {
3280af22
NIS		 1288 FmLINES(PL_formtarget) = 0;
1289 SvCUR_set(PL_formtarget, 0);
1290 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1291 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1292 (void)PerlIO_flush(fp);
3280af22 1293 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1294 }
1295 }
3280af22 1296 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1297 PUTBACK;
1298 return pop_return();
1299}
1300
1301PP(pp_prtf)
1302{
4e35701f 1303 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1304 GV *gv;
1305 IO *io;
760ac839 1306 PerlIO *fp;
26db47c4 1307 SV *sv;
46fc3d4c 1308 MAGIC *mg;
2d8e6c8d 1309 STRLEN n_a;
a0d0e21e 1310
533c011a 1311 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1312 gv = (GV*)*++MARK;
1313 else
3280af22 1314 gv = PL_defoutgv;
46fc3d4c 1315
33c27489 1316 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1317 if (MARK == ORIGMARK) {
4352c267 1318 MEXTEND(SP, 1);
46fc3d4c 1319 ++MARK;
1320 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1321 ++SP;
1322 }
1323 PUSHMARK(MARK - 1);
33c27489 1324 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1325 PUTBACK;
1326 ENTER;
864dbfa3 1327 call_method("PRINTF", G_SCALAR);
46fc3d4c 1328 LEAVE;
1329 SPAGAIN;
1330 MARK = ORIGMARK + 1;
1331 *MARK = *SP;
1332 SP = MARK;
1333 RETURN;
1334 }
1335
26db47c4 1336 sv = NEWSV(0,0);
a0d0e21e 1337 if (!(io = GvIO(gv))) {
599cee73 1338 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1339 gv_fullname3(sv, gv, Nullch);
2d8e6c8d 1340 warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1341 }
1342 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1343 goto just_say_no;
1344 }
1345 else if (!(fp = IoOFP(io))) {
599cee73 1346 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1347 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1348 if (IoIFP(io))
599cee73 1349 warner(WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 1350 SvPV(sv,n_a));
599cee73
PM		 1351 else if (ckWARN(WARN_CLOSED))
1352 warner(WARN_CLOSED, "printf on closed filehandle %s",
2d8e6c8d 1353 SvPV(sv,n_a));
a0d0e21e 1354 }
748a9306 1355 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1356 goto just_say_no;
1357 }
1358 else {
36477c24 1359#ifdef USE_LOCALE_NUMERIC
533c011a 1360 if (PL_op->op_private & OPpLOCALE)
36477c24 1361 SET_NUMERIC_LOCAL();
bbce6d69 1362 else
36477c24 1363 SET_NUMERIC_STANDARD();
1364#endif
a0d0e21e
LW		 1365 do_sprintf(sv, SP - MARK, MARK + 1);
1366 if (!do_print(sv, fp))
1367 goto just_say_no;
1368
1369 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1370 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1371 goto just_say_no;
1372 }
1373 SvREFCNT_dec(sv);
1374 SP = ORIGMARK;
3280af22 1375 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1376 RETURN;
1377
1378 just_say_no:
1379 SvREFCNT_dec(sv);
1380 SP = ORIGMARK;
3280af22 1381 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1382 RETURN;
1383}
1384
c07a80fd 1385PP(pp_sysopen)
1386{
4e35701f 1387 djSP;
c07a80fd 1388 GV *gv;
c07a80fd 1389 SV *sv;
1390 char *tmps;
1391 STRLEN len;
1392 int mode, perm;
1393
1394 if (MAXARG > 3)
1395 perm = POPi;
1396 else
1397 perm = 0666;
1398 mode = POPi;
1399 sv = POPs;
1400 gv = (GV *)POPs;
1401
4592e6ca
NIS		 1402 /* Need TIEHANDLE method ? */
1403
c07a80fd 1404 tmps = SvPV(sv, len);
1405 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1406 IoLINES(GvIOp(gv)) = 0;
3280af22 1407 PUSHs(&PL_sv_yes);
c07a80fd 1408 }
1409 else {
3280af22 1410 PUSHs(&PL_sv_undef);
c07a80fd 1411 }
1412 RETURN;
1413}
1414
a0d0e21e
LW		 1415PP(pp_sysread)
1416{
4e35701f 1417 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1418 int offset;
1419 GV *gv;
1420 IO *io;
1421 char *buffer;
5b54f415 1422 SSize_t length;
1e422769 1423 Sock_size_t bufsize;
748a9306 1424 SV *bufsv;
a0d0e21e 1425 STRLEN blen;
2ae324a7 1426 MAGIC *mg;
a0d0e21e
LW		 1427
1428 gv = (GV*)*++MARK;
533c011a 1429 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1430 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1431 {
2ae324a7 1432 SV *sv;
1433
1434 PUSHMARK(MARK-1);
33c27489 1435 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1436 ENTER;
864dbfa3 1437 call_method("READ", G_SCALAR);
2ae324a7 1438 LEAVE;
1439 SPAGAIN;
1440 sv = POPs;
1441 SP = ORIGMARK;
1442 PUSHs(sv);
1443 RETURN;
1444 }
1445
a0d0e21e
LW		 1446 if (!gv)
1447 goto say_undef;
748a9306 1448 bufsv = *++MARK;
ff68c719 1449 if (! SvOK(bufsv))
1450 sv_setpvn(bufsv, "", 0);
748a9306 1451 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1452 length = SvIVx(*++MARK);
1453 if (length < 0)
1454 DIE("Negative length");
748a9306 1455 SETERRNO(0,0);
a0d0e21e
LW		 1456 if (MARK < SP)
1457 offset = SvIVx(*++MARK);
1458 else
1459 offset = 0;
1460 io = GvIO(gv);
1461 if (!io || !IoIFP(io))
1462 goto say_undef;
1463#ifdef HAS_SOCKET
533c011a 1464 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1465 char namebuf[MAXPATHLEN];
eec2d3df 1466#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1467 bufsize = sizeof (struct sockaddr_in);
1468#else
46fc3d4c 1469 bufsize = sizeof namebuf;
490ab354 1470#endif
748a9306 1471 buffer = SvGROW(bufsv, length+1);
bbce6d69 1472 /* 'offset' means 'flags' here */
6ad3d225 1473 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1474 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1475 if (length < 0)
1476 RETPUSHUNDEF;
748a9306
LW		 1477 SvCUR_set(bufsv, length);
1478 *SvEND(bufsv) = '\0';
1479 (void)SvPOK_only(bufsv);
1480 SvSETMAGIC(bufsv);
aac0dd9a 1481 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1482 if (!(IoFLAGS(io) & IOf_UNTAINT))
1483 SvTAINTED_on(bufsv);
a0d0e21e 1484 SP = ORIGMARK;
46fc3d4c 1485 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1486 PUSHs(TARG);
1487 RETURN;
1488 }
1489#else
911d147d 1490 if (PL_op->op_type == OP_RECV)
22c35a8c 1491 DIE(PL_no_sock_func, "recv");
a0d0e21e 1492#endif
bbce6d69 1493 if (offset < 0) {
1494 if (-offset > blen)
1495 DIE("Offset outside string");
1496 offset += blen;
1497 }
cd52b7b2 1498 bufsize = SvCUR(bufsv);
748a9306 1499 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1500 if (offset > bufsize) { /* Zero any newly allocated space */
1501 Zero(buffer+bufsize, offset-bufsize, char);
1502 }
533c011a 1503 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS		 1504#ifdef PERL_SOCK_SYSREAD_IS_RECV
1505 if (IoTYPE(io) == 's') {
1506 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1507 buffer+offset, length, 0);
1508 }
1509 else
1510#endif
1511 {
1512 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1513 buffer+offset, length);
1514 }
a0d0e21e
LW		 1515 }
1516 else
1517#ifdef HAS_SOCKET__bad_code_maybe
1518 if (IoTYPE(io) == 's') {
46fc3d4c 1519 char namebuf[MAXPATHLEN];
490ab354
JH		 1520#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1521 bufsize = sizeof (struct sockaddr_in);
1522#else
46fc3d4c 1523 bufsize = sizeof namebuf;
490ab354 1524#endif
6ad3d225 1525 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1526 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1527 }
1528 else
1529#endif
3b02c43c 1530 {
760ac839 1531 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1532 /* fread() returns 0 on both error and EOF */
5c7a8c78 1533 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1534 length = -1;
1535 }
a0d0e21e
LW		 1536 if (length < 0)
1537 goto say_undef;
748a9306
LW		 1538 SvCUR_set(bufsv, length+offset);
1539 *SvEND(bufsv) = '\0';
1540 (void)SvPOK_only(bufsv);
1541 SvSETMAGIC(bufsv);
aac0dd9a 1542 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1543 if (!(IoFLAGS(io) & IOf_UNTAINT))
1544 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1545 SP = ORIGMARK;
1546 PUSHi(length);
1547 RETURN;
1548
1549 say_undef:
1550 SP = ORIGMARK;
1551 RETPUSHUNDEF;
1552}
1553
1554PP(pp_syswrite)
1555{
092bebab
JH		 1556 djSP;
1557 int items = (SP - PL_stack_base) - TOPMARK;
1558 if (items == 2) {
9f089d78 1559 SV *sv;
092bebab 1560 EXTEND(SP, 1);
9f089d78
SB		 1561 sv = sv_2mortal(newSViv(sv_len(*SP)));
1562 PUSHs(sv);
092bebab
JH		 1563 PUTBACK;
1564 }
a0d0e21e
LW		 1565 return pp_send(ARGS);
1566}
1567
1568PP(pp_send)
1569{
4e35701f 1570 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1571 GV *gv;
1572 IO *io;
1573 int offset;
748a9306 1574 SV *bufsv;
a0d0e21e
LW		 1575 char *buffer;
1576 int length;
1577 STRLEN blen;
1d603a67 1578 MAGIC *mg;
a0d0e21e
LW		 1579
1580 gv = (GV*)*++MARK;
33c27489 1581 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1582 SV *sv;
1583
1584 PUSHMARK(MARK-1);
33c27489 1585 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1586 ENTER;
864dbfa3 1587 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1588 LEAVE;
1589 SPAGAIN;
1590 sv = POPs;
1591 SP = ORIGMARK;
1592 PUSHs(sv);
1593 RETURN;
1594 }
a0d0e21e
LW		 1595 if (!gv)
1596 goto say_undef;
748a9306
LW		 1597 bufsv = *++MARK;
1598 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1599 length = SvIVx(*++MARK);
1600 if (length < 0)
1601 DIE("Negative length");
748a9306 1602 SETERRNO(0,0);
a0d0e21e
LW		 1603 io = GvIO(gv);
1604 if (!io || !IoIFP(io)) {
1605 length = -1;
599cee73 1606 if (ckWARN(WARN_CLOSED)) {
533c011a 1607 if (PL_op->op_type == OP_SYSWRITE)
599cee73 1608 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1609 else
599cee73 1610 warner(WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1611 }
1612 }
533c011a 1613 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1614 if (MARK < SP) {
a0d0e21e 1615 offset = SvIVx(*++MARK);
bbce6d69 1616 if (offset < 0) {
1617 if (-offset > blen)
1618 DIE("Offset outside string");
1619 offset += blen;
fb73857a 1620 } else if (offset >= blen && blen > 0)
bbce6d69 1621 DIE("Offset outside string");
1622 } else
a0d0e21e
LW		 1623 offset = 0;
1624 if (length > blen - offset)
1625 length = blen - offset;
a7092146
GS		 1626#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1627 if (IoTYPE(io) == 's') {
1628 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1629 buffer+offset, length, 0);
1630 }
1631 else
1632#endif
1633 {
1634 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1635 buffer+offset, length);
1636 }
a0d0e21e
LW		 1637 }
1638#ifdef HAS_SOCKET
1639 else if (SP > MARK) {
1640 char *sockbuf;
1641 STRLEN mlen;
1642 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1643 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1644 (struct sockaddr *)sockbuf, mlen);
1645 }
1646 else
6ad3d225 1647 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1648
a0d0e21e
LW		 1649#else
1650 else
22c35a8c 1651 DIE(PL_no_sock_func, "send");
a0d0e21e
LW		 1652#endif
1653 if (length < 0)
1654 goto say_undef;
1655 SP = ORIGMARK;
1656 PUSHi(length);
1657 RETURN;
1658
1659 say_undef:
1660 SP = ORIGMARK;
1661 RETPUSHUNDEF;
1662}
1663
1664PP(pp_recv)
1665{
1666 return pp_sysread(ARGS);
1667}
1668
1669PP(pp_eof)
1670{
4e35701f 1671 djSP;
a0d0e21e 1672 GV *gv;
4592e6ca 1673 MAGIC *mg;
a0d0e21e
LW		 1674
1675 if (MAXARG <= 0)
3280af22 1676 gv = PL_last_in_gv;
a0d0e21e 1677 else
3280af22 1678 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1679
1680 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1681 PUSHMARK(SP);
1682 XPUSHs(SvTIED_obj((SV*)gv, mg));
1683 PUTBACK;
1684 ENTER;
864dbfa3 1685 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1686 LEAVE;
1687 SPAGAIN;
1688 RETURN;
1689 }
1690
54310121 1691 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1692 RETURN;
1693}
1694
1695PP(pp_tell)
1696{
4e35701f 1697 djSP; dTARGET;
4592e6ca
NIS		 1698 GV *gv;
1699 MAGIC *mg;
a0d0e21e
LW		 1700
1701 if (MAXARG <= 0)
3280af22 1702 gv = PL_last_in_gv;
a0d0e21e 1703 else
3280af22 1704 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1705
1706 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1707 PUSHMARK(SP);
1708 XPUSHs(SvTIED_obj((SV*)gv, mg));
1709 PUTBACK;
1710 ENTER;
864dbfa3 1711 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1712 LEAVE;
1713 SPAGAIN;
1714 RETURN;
1715 }
1716
a0d0e21e
LW		 1717 PUSHi( do_tell(gv) );
1718 RETURN;
1719}
1720
1721PP(pp_seek)
1722{
137443ea 1723 return pp_sysseek(ARGS);
1724}
1725
1726PP(pp_sysseek)
1727{
4e35701f 1728 djSP;
a0d0e21e
LW		 1729 GV *gv;
1730 int whence = POPi;
97cc44eb 1731 Off_t offset = POPl;
4592e6ca 1732 MAGIC *mg;
a0d0e21e 1733
3280af22 1734 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1735
1736 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1737 PUSHMARK(SP);
1738 XPUSHs(SvTIED_obj((SV*)gv, mg));
1739 XPUSHs(sv_2mortal(newSViv((IV) offset)));
1740 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1741 PUTBACK;
1742 ENTER;
864dbfa3 1743 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 1744 LEAVE;
1745 SPAGAIN;
1746 RETURN;
1747 }
1748
533c011a 1749 if (PL_op->op_type == OP_SEEK)
8903cb82 1750 PUSHs(boolSV(do_seek(gv, offset, whence)));
1751 else {
97cc44eb 1752 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1753 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1754 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1755 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1756 }
a0d0e21e
LW		 1757 RETURN;
1758}
1759
1760PP(pp_truncate)
1761{
4e35701f 1762 djSP;
a0d0e21e
LW		 1763 Off_t len = (Off_t)POPn;
1764 int result = 1;
1765 GV *tmpgv;
2d8e6c8d 1766 STRLEN n_a;
a0d0e21e 1767
748a9306 1768 SETERRNO(0,0);
5d94fbed 1769#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1770 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1771 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1772 do_ftruncate:
1e422769 1773 TAINT_PROPER("truncate");
a0d0e21e 1774 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1775#ifdef HAS_TRUNCATE
760ac839 1776 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1777#else
760ac839 1778 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1779#endif
a0d0e21e
LW		 1780 result = 0;
1781 }
1782 else {
cbdc8872 1783 SV *sv = POPs;
1e422769 1784 char *name;
2d8e6c8d 1785 STRLEN n_a;
1e422769 1786
cbdc8872 1787 if (SvTYPE(sv) == SVt_PVGV) {
1788 tmpgv = (GV*)sv; /* *main::FRED for example */
1789 goto do_ftruncate;
1790 }
1791 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1792 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1793 goto do_ftruncate;
1794 }
1e422769 1795
2d8e6c8d 1796 name = SvPV(sv, n_a);
1e422769 1797 TAINT_PROPER("truncate");
cbdc8872 1798#ifdef HAS_TRUNCATE
1e422769 1799 if (truncate(name, len) < 0)
a0d0e21e 1800 result = 0;
cbdc8872 1801#else
1802 {
1803 int tmpfd;
6ad3d225 1804 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1805 result = 0;
cbdc8872 1806 else {
1807 if (my_chsize(tmpfd, len) < 0)
1808 result = 0;
6ad3d225 1809 PerlLIO_close(tmpfd);
cbdc8872 1810 }
a0d0e21e 1811 }
a0d0e21e 1812#endif
cbdc8872 1813 }
a0d0e21e
LW		 1814
1815 if (result)
1816 RETPUSHYES;
1817 if (!errno)
748a9306 1818 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1819 RETPUSHUNDEF;
1820#else
1821 DIE("truncate not implemented");
1822#endif
1823}
1824
1825PP(pp_fcntl)
1826{
1827 return pp_ioctl(ARGS);
1828}
1829
1830PP(pp_ioctl)
1831{
4e35701f 1832 djSP; dTARGET;
748a9306 1833 SV *argsv = POPs;
a0d0e21e 1834 unsigned int func = U_I(POPn);
533c011a 1835 int optype = PL_op->op_type;
a0d0e21e 1836 char *s;
324aa91a 1837 IV retval;
a0d0e21e
LW		 1838 GV *gv = (GV*)POPs;
1839 IO *io = GvIOn(gv);
1840
748a9306
LW		 1841 if (!io || !argsv || !IoIFP(io)) {
1842 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1843 RETPUSHUNDEF;
1844 }
1845
748a9306 1846 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1847 STRLEN len;
324aa91a 1848 STRLEN need;
748a9306 1849 s = SvPV_force(argsv, len);
324aa91a
HF		 1850 need = IOCPARM_LEN(func);
1851 if (len < need) {
1852 s = Sv_Grow(argsv, need + 1);
1853 SvCUR_set(argsv, need);
a0d0e21e
LW		 1854 }
1855
748a9306 1856 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1857 }
1858 else {
748a9306 1859 retval = SvIV(argsv);
a0d0e21e 1860 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1861 }
1862
1863 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1864
1865 if (optype == OP_IOCTL)
1866#ifdef HAS_IOCTL
76e3520e 1867 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1868#else
1869 DIE("ioctl is not implemented");
1870#endif
1871 else
55497cff 1872#ifdef HAS_FCNTL
1873#if defined(OS2) && defined(__EMX__)
760ac839 1874 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1875#else
760ac839 1876 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1877#endif
1878#else
a0d0e21e 1879 DIE("fcntl is not implemented");
a0d0e21e
LW		 1880#endif
1881
748a9306
LW		 1882 if (SvPOK(argsv)) {
1883 if (s[SvCUR(argsv)] != 17)
a0d0e21e 1884 DIE("Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1885 PL_op_name[optype]);
748a9306
LW		 1886 s[SvCUR(argsv)] = 0; /* put our null back */
1887 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1888 }
1889
1890 if (retval == -1)
1891 RETPUSHUNDEF;
1892 if (retval != 0) {
1893 PUSHi(retval);
1894 }
1895 else {
8903cb82 1896 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1897 }
1898 RETURN;
1899}
1900
1901PP(pp_flock)
1902{
4e35701f 1903 djSP; dTARGET;
a0d0e21e
LW		 1904 I32 value;
1905 int argtype;
1906 GV *gv;
760ac839 1907 PerlIO *fp;
16d20bd9 1908
ff68c719 1909#ifdef FLOCK
a0d0e21e
LW		 1910 argtype = POPi;
1911 if (MAXARG <= 0)
3280af22 1912 gv = PL_last_in_gv;
a0d0e21e
LW		 1913 else
1914 gv = (GV*)POPs;
1915 if (gv && GvIO(gv))
1916 fp = IoIFP(GvIOp(gv));
1917 else
1918 fp = Nullfp;
1919 if (fp) {
68dc0745 1920 (void)PerlIO_flush(fp);
76e3520e 1921 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1922 }
1923 else
1924 value = 0;
1925 PUSHi(value);
1926 RETURN;
1927#else
22c35a8c 1928 DIE(PL_no_func, "flock()");
a0d0e21e
LW		 1929#endif
1930}
1931
1932/* Sockets. */
1933
1934PP(pp_socket)
1935{
4e35701f 1936 djSP;
a0d0e21e
LW		 1937#ifdef HAS_SOCKET
1938 GV *gv;
1939 register IO *io;
1940 int protocol = POPi;
1941 int type = POPi;
1942 int domain = POPi;
1943 int fd;
1944
1945 gv = (GV*)POPs;
1946
1947 if (!gv) {
748a9306 1948 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1949 RETPUSHUNDEF;
1950 }
1951
1952 io = GvIOn(gv);
1953 if (IoIFP(io))
1954 do_close(gv, FALSE);
1955
1956 TAINT_PROPER("socket");
6ad3d225 1957 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1958 if (fd < 0)
1959 RETPUSHUNDEF;
760ac839
LW		 1960 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1961 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1962 IoTYPE(io) = 's';
1963 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1964 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1965 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1966 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1967 RETPUSHUNDEF;
1968 }
1969
1970 RETPUSHYES;
1971#else
22c35a8c 1972 DIE(PL_no_sock_func, "socket");
a0d0e21e
LW		 1973#endif
1974}
1975
1976PP(pp_sockpair)
1977{
4e35701f 1978 djSP;
a0d0e21e
LW		 1979#ifdef HAS_SOCKETPAIR
1980 GV *gv1;
1981 GV *gv2;
1982 register IO *io1;
1983 register IO *io2;
1984 int protocol = POPi;
1985 int type = POPi;
1986 int domain = POPi;
1987 int fd[2];
1988
1989 gv2 = (GV*)POPs;
1990 gv1 = (GV*)POPs;
1991 if (!gv1 || !gv2)
1992 RETPUSHUNDEF;
1993
1994 io1 = GvIOn(gv1);
1995 io2 = GvIOn(gv2);
1996 if (IoIFP(io1))
1997 do_close(gv1, FALSE);
1998 if (IoIFP(io2))
1999 do_close(gv2, FALSE);
2000
2001 TAINT_PROPER("socketpair");
6ad3d225 2002 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2003 RETPUSHUNDEF;
760ac839
LW		 2004 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2005 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2006 IoTYPE(io1) = 's';
760ac839
LW		 2007 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2008 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 2009 IoTYPE(io2) = 's';
2010 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2011 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2012 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2013 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2014 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2015 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2016 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2017 RETPUSHUNDEF;
2018 }
2019
2020 RETPUSHYES;
2021#else
22c35a8c 2022 DIE(PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2023#endif
2024}
2025
2026PP(pp_bind)
2027{
4e35701f 2028 djSP;
a0d0e21e 2029#ifdef HAS_SOCKET
eec2d3df
GS		 2030#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2031 extern GETPRIVMODE();
2032 extern GETUSERMODE();
2033#endif
748a9306 2034 SV *addrsv = POPs;
a0d0e21e
LW		 2035 char *addr;
2036 GV *gv = (GV*)POPs;
2037 register IO *io = GvIOn(gv);
2038 STRLEN len;
eec2d3df
GS		 2039 int bind_ok = 0;
2040#ifdef MPE
2041 int mpeprivmode = 0;
2042#endif
a0d0e21e
LW		 2043
2044 if (!io || !IoIFP(io))
2045 goto nuts;
2046
748a9306 2047 addr = SvPV(addrsv, len);
a0d0e21e 2048 TAINT_PROPER("bind");
eec2d3df
GS		 2049#ifdef MPE /* Deal with MPE bind() peculiarities */
2050 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2051 /* The address *MUST* stupidly be zero. */
2052 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2053 /* PRIV mode is required to bind() to ports < 1024. */
2054 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2055 ((struct sockaddr_in *)addr)->sin_port > 0) {
2056 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2057 mpeprivmode = 1;
2058 }
2059 }
2060#endif /* MPE */
2061 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2062 (struct sockaddr *)addr, len) >= 0)
2063 bind_ok = 1;
2064
2065#ifdef MPE /* Switch back to USER mode */
2066 if (mpeprivmode)
2067 GETUSERMODE();
2068#endif /* MPE */
2069
2070 if (bind_ok)
a0d0e21e
LW		 2071 RETPUSHYES;
2072 else
2073 RETPUSHUNDEF;
2074
2075nuts:
599cee73
PM		 2076 if (ckWARN(WARN_CLOSED))
2077 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 2078 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2079 RETPUSHUNDEF;
2080#else
22c35a8c 2081 DIE(PL_no_sock_func, "bind");
a0d0e21e
LW		 2082#endif
2083}
2084
2085PP(pp_connect)
2086{
4e35701f 2087 djSP;
a0d0e21e 2088#ifdef HAS_SOCKET
748a9306 2089 SV *addrsv = POPs;
a0d0e21e
LW		 2090 char *addr;
2091 GV *gv = (GV*)POPs;
2092 register IO *io = GvIOn(gv);
2093 STRLEN len;
2094
2095 if (!io || !IoIFP(io))
2096 goto nuts;
2097
748a9306 2098 addr = SvPV(addrsv, len);
a0d0e21e 2099 TAINT_PROPER("connect");
6ad3d225 2100 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2101 RETPUSHYES;
2102 else
2103 RETPUSHUNDEF;
2104
2105nuts:
599cee73
PM		 2106 if (ckWARN(WARN_CLOSED))
2107 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 2108 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2109 RETPUSHUNDEF;
2110#else
22c35a8c 2111 DIE(PL_no_sock_func, "connect");
a0d0e21e
LW		 2112#endif
2113}
2114
2115PP(pp_listen)
2116{
4e35701f 2117 djSP;
a0d0e21e
LW		 2118#ifdef HAS_SOCKET
2119 int backlog = POPi;
2120 GV *gv = (GV*)POPs;
2121 register IO *io = GvIOn(gv);
2122
2123 if (!io || !IoIFP(io))
2124 goto nuts;
2125
6ad3d225 2126 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2127 RETPUSHYES;
2128 else
2129 RETPUSHUNDEF;
2130
2131nuts:
599cee73
PM		 2132 if (ckWARN(WARN_CLOSED))
2133 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 2134 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2135 RETPUSHUNDEF;
2136#else
22c35a8c 2137 DIE(PL_no_sock_func, "listen");
a0d0e21e
LW		 2138#endif
2139}
2140
2141PP(pp_accept)
2142{
4e35701f 2143 djSP; dTARGET;
a0d0e21e
LW		 2144#ifdef HAS_SOCKET
2145 GV *ngv;
2146 GV *ggv;
2147 register IO *nstio;
2148 register IO *gstio;
4633a7c4 2149 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2150 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2151 int fd;
2152
2153 ggv = (GV*)POPs;
2154 ngv = (GV*)POPs;
2155
2156 if (!ngv)
2157 goto badexit;
2158 if (!ggv)
2159 goto nuts;
2160
2161 gstio = GvIO(ggv);
2162 if (!gstio || !IoIFP(gstio))
2163 goto nuts;
2164
2165 nstio = GvIOn(ngv);
2166 if (IoIFP(nstio))
2167 do_close(ngv, FALSE);
2168
6ad3d225 2169 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2170 if (fd < 0)
2171 goto badexit;
760ac839
LW		 2172 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2173 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2174 IoTYPE(nstio) = 's';
2175 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2176 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2177 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2178 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2179 goto badexit;
2180 }
2181
748a9306 2182 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2183 RETURN;
2184
2185nuts:
599cee73
PM		 2186 if (ckWARN(WARN_CLOSED))
2187 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2188 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2189
2190badexit:
2191 RETPUSHUNDEF;
2192
2193#else
22c35a8c 2194 DIE(PL_no_sock_func, "accept");
a0d0e21e
LW		 2195#endif
2196}
2197
2198PP(pp_shutdown)
2199{
4e35701f 2200 djSP; dTARGET;
a0d0e21e
LW		 2201#ifdef HAS_SOCKET
2202 int how = POPi;
2203 GV *gv = (GV*)POPs;
2204 register IO *io = GvIOn(gv);
2205
2206 if (!io || !IoIFP(io))
2207 goto nuts;
2208
6ad3d225 2209 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2210 RETURN;
2211
2212nuts:
599cee73
PM		 2213 if (ckWARN(WARN_CLOSED))
2214 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2215 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2216 RETPUSHUNDEF;
2217#else
22c35a8c 2218 DIE(PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2219#endif
2220}
2221
2222PP(pp_gsockopt)
2223{
2224#ifdef HAS_SOCKET
2225 return pp_ssockopt(ARGS);
2226#else
22c35a8c 2227 DIE(PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2228#endif
2229}
2230
2231PP(pp_ssockopt)
2232{
4e35701f 2233 djSP;
a0d0e21e 2234#ifdef HAS_SOCKET
533c011a 2235 int optype = PL_op->op_type;
a0d0e21e
LW		 2236 SV *sv;
2237 int fd;
2238 unsigned int optname;
2239 unsigned int lvl;
2240 GV *gv;
2241 register IO *io;
1e422769 2242 Sock_size_t len;
a0d0e21e
LW		 2243
2244 if (optype == OP_GSOCKOPT)
2245 sv = sv_2mortal(NEWSV(22, 257));
2246 else
2247 sv = POPs;
2248 optname = (unsigned int) POPi;
2249 lvl = (unsigned int) POPi;
2250
2251 gv = (GV*)POPs;
2252 io = GvIOn(gv);
2253 if (!io || !IoIFP(io))
2254 goto nuts;
2255
760ac839 2256 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2257 switch (optype) {
2258 case OP_GSOCKOPT:
748a9306 2259 SvGROW(sv, 257);
a0d0e21e 2260 (void)SvPOK_only(sv);
748a9306
LW		 2261 SvCUR_set(sv,256);
2262 *SvEND(sv) ='\0';
1e422769 2263 len = SvCUR(sv);
6ad3d225 2264 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2265 goto nuts2;
1e422769 2266 SvCUR_set(sv, len);
748a9306 2267 *SvEND(sv) ='\0';
a0d0e21e
LW		 2268 PUSHs(sv);
2269 break;
2270 case OP_SSOCKOPT: {
1e422769 2271 char *buf;
2272 int aint;
2273 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2274 STRLEN l;
2275 buf = SvPV(sv, l);
2276 len = l;
1e422769 2277 }
56ee1660 2278 else {
a0d0e21e
LW		 2279 aint = (int)SvIV(sv);
2280 buf = (char*)&aint;
2281 len = sizeof(int);
2282 }
6ad3d225 2283 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2284 goto nuts2;
3280af22 2285 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2286 }
2287 break;
2288 }
2289 RETURN;
2290
2291nuts:
599cee73
PM		 2292 if (ckWARN(WARN_CLOSED))
2293 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2294 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2295nuts2:
2296 RETPUSHUNDEF;
2297
2298#else
22c35a8c 2299 DIE(PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2300#endif
2301}
2302
2303PP(pp_getsockname)
2304{
2305#ifdef HAS_SOCKET
2306 return pp_getpeername(ARGS);
2307#else
22c35a8c 2308 DIE(PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2309#endif
2310}
2311
2312PP(pp_getpeername)
2313{
4e35701f 2314 djSP;
a0d0e21e 2315#ifdef HAS_SOCKET
533c011a 2316 int optype = PL_op->op_type;
a0d0e21e
LW		 2317 SV *sv;
2318 int fd;
2319 GV *gv = (GV*)POPs;
2320 register IO *io = GvIOn(gv);
1e422769 2321 Sock_size_t len;
a0d0e21e
LW		 2322
2323 if (!io || !IoIFP(io))
2324 goto nuts;
2325
2326 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2327 (void)SvPOK_only(sv);
1e422769 2328 len = 256;
2329 SvCUR_set(sv, len);
748a9306 2330 *SvEND(sv) ='\0';
760ac839 2331 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2332 switch (optype) {
2333 case OP_GETSOCKNAME:
6ad3d225 2334 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2335 goto nuts2;
2336 break;
2337 case OP_GETPEERNAME:
6ad3d225 2338 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2339 goto nuts2;
490ab354
JH		 2340#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2341 {
2342 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";
2343 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2344 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2345 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2346 sizeof(u_short) + sizeof(struct in_addr))) {
2347 goto nuts2;
2348 }
2349 }
2350#endif
a0d0e21e
LW		 2351 break;
2352 }
13826f2c
CS		 2353#ifdef BOGUS_GETNAME_RETURN
2354 /* Interactive Unix, getpeername() and getsockname()
2355 does not return valid namelen */
1e422769 2356 if (len == BOGUS_GETNAME_RETURN)
2357 len = sizeof(struct sockaddr);
13826f2c 2358#endif
1e422769 2359 SvCUR_set(sv, len);
748a9306 2360 *SvEND(sv) ='\0';
a0d0e21e
LW		 2361 PUSHs(sv);
2362 RETURN;
2363
2364nuts:
599cee73
PM		 2365 if (ckWARN(WARN_CLOSED))
2366 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2367 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2368nuts2:
2369 RETPUSHUNDEF;
2370
2371#else
22c35a8c 2372 DIE(PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2373#endif
2374}
2375
2376/* Stat calls. */
2377
2378PP(pp_lstat)
2379{
2380 return pp_stat(ARGS);
2381}
2382
2383PP(pp_stat)
2384{
4e35701f 2385 djSP;
a0d0e21e 2386 GV *tmpgv;
54310121 2387 I32 gimme;
a0d0e21e 2388 I32 max = 13;
2d8e6c8d 2389 STRLEN n_a;
a0d0e21e 2390
533c011a 2391 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2392 tmpgv = cGVOP->op_gv;
748a9306 2393 do_fstat:
3280af22
NIS		 2394 if (tmpgv != PL_defgv) {
2395 PL_laststype = OP_STAT;
2396 PL_statgv = tmpgv;
2397 sv_setpv(PL_statname, "");
2398 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2399 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2400 }
3280af22 2401 if (PL_laststatval < 0)
a0d0e21e
LW		 2402 max = 0;
2403 }
2404 else {
748a9306
LW		 2405 SV* sv = POPs;
2406 if (SvTYPE(sv) == SVt_PVGV) {
2407 tmpgv = (GV*)sv;
2408 goto do_fstat;
2409 }
2410 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2411 tmpgv = (GV*)SvRV(sv);
2412 goto do_fstat;
2413 }
2d8e6c8d 2414 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2415 PL_statgv = Nullgv;
a0d0e21e 2416#ifdef HAS_LSTAT
533c011a
NIS		 2417 PL_laststype = PL_op->op_type;
2418 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2419 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2420 else
2421#endif
2d8e6c8d 2422 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2423 if (PL_laststatval < 0) {
2d8e6c8d 2424 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
22c35a8c 2425 warner(WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2426 max = 0;
2427 }
2428 }
2429
54310121 2430 gimme = GIMME_V;
2431 if (gimme != G_ARRAY) {
2432 if (gimme != G_VOID)
2433 XPUSHs(boolSV(max));
2434 RETURN;
a0d0e21e
LW		 2435 }
2436 if (max) {
36477c24 2437 EXTEND(SP, max);
2438 EXTEND_MORTAL(max);
3280af22
NIS		 2439 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2440 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2441 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2442 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2443 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2444 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2445#ifdef USE_STAT_RDEV
3280af22 2446 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2447#else
79cb57f6 2448 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2449#endif
3280af22 2450 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2451#ifdef BIG_TIME
6b88bc9c
GS		 2452 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2453 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2454 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2455#else
3280af22
NIS		 2456 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2457 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2458 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2459#endif
a0d0e21e 2460#ifdef USE_STAT_BLOCKS
3280af22
NIS		 2461 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2462 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e 2463#else
79cb57f6
GS		 2464 PUSHs(sv_2mortal(newSVpvn("", 0)));
2465 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2466#endif
2467 }
2468 RETURN;
2469}
2470
2471PP(pp_ftrread)
2472{
5ff3f7a4 2473 I32 result;
4e35701f 2474 djSP;
5ff3f7a4 2475#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2476 STRLEN n_a;
5ff3f7a4 2477 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2478 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2479 if (result == 0)
2480 RETPUSHYES;
2481 if (result < 0)
2482 RETPUSHUNDEF;
2483 RETPUSHNO;
22865c03
GS		 2484 }
2485 else
5ff3f7a4
GS		 2486 result = my_stat(ARGS);
2487#else
2488 result = my_stat(ARGS);
2489#endif
22865c03 2490 SPAGAIN;
a0d0e21e
LW		 2491 if (result < 0)
2492 RETPUSHUNDEF;
3280af22 2493 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2494 RETPUSHYES;
2495 RETPUSHNO;
2496}
2497
2498PP(pp_ftrwrite)
2499{
5ff3f7a4 2500 I32 result;
4e35701f 2501 djSP;
5ff3f7a4 2502#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2503 STRLEN n_a;
5ff3f7a4 2504 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2505 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2506 if (result == 0)
2507 RETPUSHYES;
2508 if (result < 0)
2509 RETPUSHUNDEF;
2510 RETPUSHNO;
22865c03
GS		 2511 }
2512 else
5ff3f7a4
GS		 2513 result = my_stat(ARGS);
2514#else
2515 result = my_stat(ARGS);
2516#endif
22865c03 2517 SPAGAIN;
a0d0e21e
LW		 2518 if (result < 0)
2519 RETPUSHUNDEF;
3280af22 2520 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2521 RETPUSHYES;
2522 RETPUSHNO;
2523}
2524
2525PP(pp_ftrexec)
2526{
5ff3f7a4 2527 I32 result;
4e35701f 2528 djSP;
5ff3f7a4 2529#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2530 STRLEN n_a;
5ff3f7a4 2531 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2532 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2533 if (result == 0)
2534 RETPUSHYES;
2535 if (result < 0)
2536 RETPUSHUNDEF;
2537 RETPUSHNO;
22865c03
GS		 2538 }
2539 else
5ff3f7a4
GS		 2540 result = my_stat(ARGS);
2541#else
2542 result = my_stat(ARGS);
2543#endif
22865c03 2544 SPAGAIN;
a0d0e21e
LW		 2545 if (result < 0)
2546 RETPUSHUNDEF;
3280af22 2547 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2548 RETPUSHYES;
2549 RETPUSHNO;
2550}
2551
2552PP(pp_fteread)
2553{
5ff3f7a4 2554 I32 result;
4e35701f 2555 djSP;
5ff3f7a4 2556#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2557 STRLEN n_a;
5ff3f7a4 2558 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2559 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2560 if (result == 0)
2561 RETPUSHYES;
2562 if (result < 0)
2563 RETPUSHUNDEF;
2564 RETPUSHNO;
22865c03
GS		 2565 }
2566 else
5ff3f7a4
GS		 2567 result = my_stat(ARGS);
2568#else
2569 result = my_stat(ARGS);
2570#endif
22865c03 2571 SPAGAIN;
a0d0e21e
LW		 2572 if (result < 0)
2573 RETPUSHUNDEF;
3280af22 2574 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2575 RETPUSHYES;
2576 RETPUSHNO;
2577}
2578
2579PP(pp_ftewrite)
2580{
5ff3f7a4 2581 I32 result;
4e35701f 2582 djSP;
5ff3f7a4 2583#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2584 STRLEN n_a;
5ff3f7a4 2585 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2586 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2587 if (result == 0)
2588 RETPUSHYES;
2589 if (result < 0)
2590 RETPUSHUNDEF;
2591 RETPUSHNO;
22865c03
GS		 2592 }
2593 else
5ff3f7a4
GS		 2594 result = my_stat(ARGS);
2595#else
2596 result = my_stat(ARGS);
2597#endif
22865c03 2598 SPAGAIN;
a0d0e21e
LW		 2599 if (result < 0)
2600 RETPUSHUNDEF;
3280af22 2601 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2602 RETPUSHYES;
2603 RETPUSHNO;
2604}
2605
2606PP(pp_fteexec)
2607{
5ff3f7a4 2608 I32 result;
4e35701f 2609 djSP;
5ff3f7a4 2610#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2611 STRLEN n_a;
5ff3f7a4 2612 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2613 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2614 if (result == 0)
2615 RETPUSHYES;
2616 if (result < 0)
2617 RETPUSHUNDEF;
2618 RETPUSHNO;
22865c03
GS		 2619 }
2620 else
5ff3f7a4
GS		 2621 result = my_stat(ARGS);
2622#else
2623 result = my_stat(ARGS);
2624#endif
22865c03 2625 SPAGAIN;
a0d0e21e
LW		 2626 if (result < 0)
2627 RETPUSHUNDEF;
3280af22 2628 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2629 RETPUSHYES;
2630 RETPUSHNO;
2631}
2632
2633PP(pp_ftis)
2634{
2635 I32 result = my_stat(ARGS);
4e35701f 2636 djSP;
a0d0e21e
LW		 2637 if (result < 0)
2638 RETPUSHUNDEF;
2639 RETPUSHYES;
2640}
2641
2642PP(pp_fteowned)
2643{
2644 return pp_ftrowned(ARGS);
2645}
2646
2647PP(pp_ftrowned)
2648{
2649 I32 result = my_stat(ARGS);
4e35701f 2650 djSP;
a0d0e21e
LW		 2651 if (result < 0)
2652 RETPUSHUNDEF;
533c011a 2653 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2654 RETPUSHYES;
2655 RETPUSHNO;
2656}
2657
2658PP(pp_ftzero)
2659{
2660 I32 result = my_stat(ARGS);
4e35701f 2661 djSP;
a0d0e21e
LW		 2662 if (result < 0)
2663 RETPUSHUNDEF;
3280af22 2664 if (!PL_statcache.st_size)
a0d0e21e
LW		 2665 RETPUSHYES;
2666 RETPUSHNO;
2667}
2668
2669PP(pp_ftsize)
2670{
2671 I32 result = my_stat(ARGS);
4e35701f 2672 djSP; dTARGET;
a0d0e21e
LW		 2673 if (result < 0)
2674 RETPUSHUNDEF;
3280af22 2675 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2676 RETURN;
2677}
2678
2679PP(pp_ftmtime)
2680{
2681 I32 result = my_stat(ARGS);
4e35701f 2682 djSP; dTARGET;
a0d0e21e
LW		 2683 if (result < 0)
2684 RETPUSHUNDEF;
3280af22 2685 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2686 RETURN;
2687}
2688
2689PP(pp_ftatime)
2690{
2691 I32 result = my_stat(ARGS);
4e35701f 2692 djSP; dTARGET;
a0d0e21e
LW		 2693 if (result < 0)
2694 RETPUSHUNDEF;
3280af22 2695 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2696 RETURN;
2697}
2698
2699PP(pp_ftctime)
2700{
2701 I32 result = my_stat(ARGS);
4e35701f 2702 djSP; dTARGET;
a0d0e21e
LW		 2703 if (result < 0)
2704 RETPUSHUNDEF;
3280af22 2705 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2706 RETURN;
2707}
2708
2709PP(pp_ftsock)
2710{
2711 I32 result = my_stat(ARGS);
4e35701f 2712 djSP;
a0d0e21e
LW		 2713 if (result < 0)
2714 RETPUSHUNDEF;
3280af22 2715 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2716 RETPUSHYES;
2717 RETPUSHNO;
2718}
2719
2720PP(pp_ftchr)
2721{
2722 I32 result = my_stat(ARGS);
4e35701f 2723 djSP;
a0d0e21e
LW		 2724 if (result < 0)
2725 RETPUSHUNDEF;
3280af22 2726 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2727 RETPUSHYES;
2728 RETPUSHNO;
2729}
2730
2731PP(pp_ftblk)
2732{
2733 I32 result = my_stat(ARGS);
4e35701f 2734 djSP;
a0d0e21e
LW		 2735 if (result < 0)
2736 RETPUSHUNDEF;
3280af22 2737 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2738 RETPUSHYES;
2739 RETPUSHNO;
2740}
2741
2742PP(pp_ftfile)
2743{
2744 I32 result = my_stat(ARGS);
4e35701f 2745 djSP;
a0d0e21e
LW		 2746 if (result < 0)
2747 RETPUSHUNDEF;
3280af22 2748 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2749 RETPUSHYES;
2750 RETPUSHNO;
2751}
2752
2753PP(pp_ftdir)
2754{
2755 I32 result = my_stat(ARGS);
4e35701f 2756 djSP;
a0d0e21e
LW		 2757 if (result < 0)
2758 RETPUSHUNDEF;
3280af22 2759 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2760 RETPUSHYES;
2761 RETPUSHNO;
2762}
2763
2764PP(pp_ftpipe)
2765{
2766 I32 result = my_stat(ARGS);
4e35701f 2767 djSP;
a0d0e21e
LW		 2768 if (result < 0)
2769 RETPUSHUNDEF;
3280af22 2770 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2771 RETPUSHYES;
2772 RETPUSHNO;
2773}
2774
2775PP(pp_ftlink)
2776{
2777 I32 result = my_lstat(ARGS);
4e35701f 2778 djSP;
a0d0e21e
LW		 2779 if (result < 0)
2780 RETPUSHUNDEF;
3280af22 2781 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2782 RETPUSHYES;
2783 RETPUSHNO;
2784}
2785
2786PP(pp_ftsuid)
2787{
4e35701f 2788 djSP;
a0d0e21e
LW		 2789#ifdef S_ISUID
2790 I32 result = my_stat(ARGS);
2791 SPAGAIN;
2792 if (result < 0)
2793 RETPUSHUNDEF;
3280af22 2794 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2795 RETPUSHYES;
2796#endif
2797 RETPUSHNO;
2798}
2799
2800PP(pp_ftsgid)
2801{
4e35701f 2802 djSP;
a0d0e21e
LW		 2803#ifdef S_ISGID
2804 I32 result = my_stat(ARGS);
2805 SPAGAIN;
2806 if (result < 0)
2807 RETPUSHUNDEF;
3280af22 2808 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2809 RETPUSHYES;
2810#endif
2811 RETPUSHNO;
2812}
2813
2814PP(pp_ftsvtx)
2815{
4e35701f 2816 djSP;
a0d0e21e
LW		 2817#ifdef S_ISVTX
2818 I32 result = my_stat(ARGS);
2819 SPAGAIN;
2820 if (result < 0)
2821 RETPUSHUNDEF;
3280af22 2822 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2823 RETPUSHYES;
2824#endif
2825 RETPUSHNO;
2826}
2827
2828PP(pp_fttty)
2829{
4e35701f 2830 djSP;
a0d0e21e
LW		 2831 int fd;
2832 GV *gv;
fb73857a 2833 char *tmps = Nullch;
2d8e6c8d 2834 STRLEN n_a;
fb73857a 2835
533c011a 2836 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2837 gv = cGVOP->op_gv;
fb73857a 2838 else if (isGV(TOPs))
2839 gv = (GV*)POPs;
2840 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2841 gv = (GV*)SvRV(POPs);
a0d0e21e 2842 else
2d8e6c8d 2843 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2844
a0d0e21e 2845 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2846 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2847 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2848 fd = atoi(tmps);
2849 else
2850 RETPUSHUNDEF;
6ad3d225 2851 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2852 RETPUSHYES;
2853 RETPUSHNO;
2854}
2855
16d20bd9
AD		 2856#if defined(atarist) /* this will work with atariST. Configure will
2857 make guesses for other systems. */
2858# define FILE_base(f) ((f)->_base)
2859# define FILE_ptr(f) ((f)->_ptr)
2860# define FILE_cnt(f) ((f)->_cnt)
2861# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2862#endif
2863
2864PP(pp_fttext)
2865{
4e35701f 2866 djSP;
a0d0e21e
LW		 2867 I32 i;
2868 I32 len;
2869 I32 odd = 0;
2870 STDCHAR tbuf[512];
2871 register STDCHAR *s;
2872 register IO *io;
5f05dabc 2873 register SV *sv;
2874 GV *gv;
2d8e6c8d 2875 STRLEN n_a;
a0d0e21e 2876
533c011a 2877 if (PL_op->op_flags & OPf_REF)
5f05dabc 2878 gv = cGVOP->op_gv;
2879 else if (isGV(TOPs))
2880 gv = (GV*)POPs;
2881 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2882 gv = (GV*)SvRV(POPs);
2883 else
2884 gv = Nullgv;
2885
2886 if (gv) {
a0d0e21e 2887 EXTEND(SP, 1);
3280af22
NIS		 2888 if (gv == PL_defgv) {
2889 if (PL_statgv)
2890 io = GvIO(PL_statgv);
a0d0e21e 2891 else {
3280af22 2892 sv = PL_statname;
a0d0e21e
LW		 2893 goto really_filename;
2894 }
2895 }
2896 else {
3280af22
NIS		 2897 PL_statgv = gv;
2898 PL_laststatval = -1;
2899 sv_setpv(PL_statname, "");
2900 io = GvIO(PL_statgv);
a0d0e21e
LW		 2901 }
2902 if (io && IoIFP(io)) {
5f05dabc 2903 if (! PerlIO_has_base(IoIFP(io)))
2904 DIE("-T and -B not implemented on filehandles");
3280af22
NIS		 2905 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2906 if (PL_laststatval < 0)
5f05dabc 2907 RETPUSHUNDEF;
3280af22 2908 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2909 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2910 RETPUSHNO;
2911 else
2912 RETPUSHYES;
760ac839
LW		 2913 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2914 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2915 if (i != EOF)
760ac839 2916 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2917 }
760ac839 2918 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2919 RETPUSHYES;
760ac839
LW		 2920 len = PerlIO_get_bufsiz(IoIFP(io));
2921 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2922 /* sfio can have large buffers - limit to 512 */
2923 if (len > 512)
2924 len = 512;
a0d0e21e
LW		 2925 }
2926 else {
599cee73
PM		 2927 if (ckWARN(WARN_UNOPENED))
2928 warner(WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2929 GvENAME(cGVOP->op_gv));
748a9306 2930 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2931 RETPUSHUNDEF;
2932 }
2933 }
2934 else {
2935 sv = POPs;
5f05dabc 2936 really_filename:
3280af22
NIS		 2937 PL_statgv = Nullgv;
2938 PL_laststatval = -1;
2d8e6c8d 2939 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2940#ifdef HAS_OPEN3
2d8e6c8d 2941 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2942#else
2d8e6c8d 2943 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW		 2944#endif
2945 if (i < 0) {
2d8e6c8d 2946 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
22c35a8c 2947 warner(WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 2948 RETPUSHUNDEF;
2949 }
3280af22
NIS		 2950 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2951 if (PL_laststatval < 0)
5f05dabc 2952 RETPUSHUNDEF;
6ad3d225
GS		 2953 len = PerlLIO_read(i, tbuf, 512);
2954 (void)PerlLIO_close(i);
a0d0e21e 2955 if (len <= 0) {
533c011a 2956 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2957 RETPUSHNO; /* special case NFS directories */
2958 RETPUSHYES; /* null file is anything */
2959 }
2960 s = tbuf;
2961 }
2962
2963 /* now scan s to look for textiness */
4633a7c4 2964 /* XXX ASCII dependent code */
a0d0e21e
LW		 2965
2966 for (i = 0; i < len; i++, s++) {
2967 if (!*s) { /* null never allowed in text */
2968 odd += len;
2969 break;
2970 }
9d116dd7
JH		 2971#ifdef EBCDIC
2972 else if (!(isPRINT(*s) || isSPACE(*s)))
2973 odd++;
2974#else
a0d0e21e
LW		 2975 else if (*s & 128)
2976 odd++;
2977 else if (*s < 32 &&
2978 *s != '\n' && *s != '\r' && *s != '\b' &&
2979 *s != '\t' && *s != '\f' && *s != 27)
2980 odd++;
9d116dd7 2981#endif
a0d0e21e
LW		 2982 }
2983
533c011a 2984 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2985 RETPUSHNO;
2986 else
2987 RETPUSHYES;
2988}
2989
2990PP(pp_ftbinary)
2991{
2992 return pp_fttext(ARGS);
2993}
2994
2995/* File calls. */
2996
2997PP(pp_chdir)
2998{
4e35701f 2999 djSP; dTARGET;
a0d0e21e
LW		 3000 char *tmps;
3001 SV **svp;
2d8e6c8d 3002 STRLEN n_a;
a0d0e21e
LW		 3003
3004 if (MAXARG < 1)
3005 tmps = Nullch;
3006 else
2d8e6c8d 3007 tmps = POPpx;
a0d0e21e 3008 if (!tmps || !*tmps) {
3280af22 3009 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3010 if (svp)
2d8e6c8d 3011 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3012 }
3013 if (!tmps || !*tmps) {
3280af22 3014 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3015 if (svp)
2d8e6c8d 3016 tmps = SvPV(*svp, n_a);
a0d0e21e 3017 }
491527d0
GS		 3018#ifdef VMS
3019 if (!tmps || !*tmps) {
6b88bc9c 3020 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3021 if (svp)
2d8e6c8d 3022 tmps = SvPV(*svp, n_a);
491527d0
GS		 3023 }
3024#endif
a0d0e21e 3025 TAINT_PROPER("chdir");
6ad3d225 3026 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3027#ifdef VMS
3028 /* Clear the DEFAULT element of ENV so we'll get the new value
3029 * in the future. */
6b88bc9c 3030 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3031#endif
a0d0e21e
LW		 3032 RETURN;
3033}
3034
3035PP(pp_chown)
3036{
4e35701f 3037 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3038 I32 value;
3039#ifdef HAS_CHOWN
533c011a 3040 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3041 SP = MARK;
3042 PUSHi(value);
3043 RETURN;
3044#else
22c35a8c 3045 DIE(PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3046#endif
3047}
3048
3049PP(pp_chroot)
3050{
4e35701f 3051 djSP; dTARGET;
a0d0e21e
LW		 3052 char *tmps;
3053#ifdef HAS_CHROOT
2d8e6c8d
GS		 3054 STRLEN n_a;
3055 tmps = POPpx;
a0d0e21e
LW		 3056 TAINT_PROPER("chroot");
3057 PUSHi( chroot(tmps) >= 0 );
3058 RETURN;
3059#else
22c35a8c 3060 DIE(PL_no_func, "chroot");
a0d0e21e
LW		 3061#endif
3062}
3063
3064PP(pp_unlink)
3065{
4e35701f 3066 djSP; dMARK; dTARGET;
a0d0e21e 3067 I32 value;
533c011a 3068 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3069 SP = MARK;
3070 PUSHi(value);
3071 RETURN;
3072}
3073
3074PP(pp_chmod)
3075{
4e35701f 3076 djSP; dMARK; dTARGET;
a0d0e21e 3077 I32 value;
533c011a 3078 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3079 SP = MARK;
3080 PUSHi(value);
3081 RETURN;
3082}
3083
3084PP(pp_utime)
3085{
4e35701f 3086 djSP; dMARK; dTARGET;
a0d0e21e 3087 I32 value;
533c011a 3088 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3089 SP = MARK;
3090 PUSHi(value);
3091 RETURN;
3092}
3093
3094PP(pp_rename)
3095{
4e35701f 3096 djSP; dTARGET;
a0d0e21e 3097 int anum;
2d8e6c8d 3098 STRLEN n_a;
a0d0e21e 3099
2d8e6c8d
GS		 3100 char *tmps2 = POPpx;
3101 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3102 TAINT_PROPER("rename");
3103#ifdef HAS_RENAME
baed7233 3104 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3105#else
6b88bc9c 3106 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3107 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3108 anum = 1;
3109 else {
3654eb6c 3110 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3111 (void)UNLINK(tmps2);
3112 if (!(anum = link(tmps, tmps2)))
3113 anum = UNLINK(tmps);
3114 }
a0d0e21e
LW		 3115 }
3116#endif
3117 SETi( anum >= 0 );
3118 RETURN;
3119}
3120
3121PP(pp_link)
3122{
4e35701f 3123 djSP; dTARGET;
a0d0e21e 3124#ifdef HAS_LINK
2d8e6c8d
GS		 3125 STRLEN n_a;
3126 char *tmps2 = POPpx;
3127 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3128 TAINT_PROPER("link");
3129 SETi( link(tmps, tmps2) >= 0 );
3130#else
22c35a8c 3131 DIE(PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3132#endif
3133 RETURN;
3134}
3135
3136PP(pp_symlink)
3137{
4e35701f 3138 djSP; dTARGET;
a0d0e21e 3139#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3140 STRLEN n_a;
3141 char *tmps2 = POPpx;
3142 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3143 TAINT_PROPER("symlink");
3144 SETi( symlink(tmps, tmps2) >= 0 );
3145 RETURN;
3146#else
22c35a8c 3147 DIE(PL_no_func, "symlink");
a0d0e21e
LW		 3148#endif
3149}
3150
3151PP(pp_readlink)
3152{
4e35701f 3153 djSP; dTARGET;
a0d0e21e
LW		 3154#ifdef HAS_SYMLINK
3155 char *tmps;
46fc3d4c 3156 char buf[MAXPATHLEN];
a0d0e21e 3157 int len;
2d8e6c8d 3158 STRLEN n_a;
46fc3d4c 3159
fb73857a 3160#ifndef INCOMPLETE_TAINTS
3161 TAINT;
3162#endif
2d8e6c8d 3163 tmps = POPpx;
a0d0e21e
LW		 3164 len = readlink(tmps, buf, sizeof buf);
3165 EXTEND(SP, 1);
3166 if (len < 0)
3167 RETPUSHUNDEF;
3168 PUSHp(buf, len);
3169 RETURN;
3170#else
3171 EXTEND(SP, 1);
3172 RETSETUNDEF; /* just pretend it's a normal file */
3173#endif
3174}
3175
3176#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3177STATIC int
864dbfa3 3178dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3179{
1e422769 3180 char *save_filename = filename;
3181 char *cmdline;
3182 char *s;
760ac839 3183 PerlIO *myfp;
1e422769 3184 int anum = 1;
a0d0e21e 3185
1e422769 3186 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3187 strcpy(cmdline, cmd);
3188 strcat(cmdline, " ");
3189 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3190 *s++ = '\\';
3191 *s++ = *filename++;
3192 }
3193 strcpy(s, " 2>&1");
6ad3d225 3194 myfp = PerlProc_popen(cmdline, "r");
1e422769 3195 Safefree(cmdline);
3196
a0d0e21e 3197 if (myfp) {
1e422769 3198 SV *tmpsv = sv_newmortal();
6b88bc9c 3199 /* Need to save/restore 'PL_rs' ?? */
760ac839 3200 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3201 (void)PerlProc_pclose(myfp);
a0d0e21e 3202 if (s != Nullch) {
1e422769 3203 int e;
3204 for (e = 1;
a0d0e21e 3205#ifdef HAS_SYS_ERRLIST
1e422769 3206 e <= sys_nerr
3207#endif
3208 ; e++)
3209 {
3210 /* you don't see this */
3211 char *errmsg =
3212#ifdef HAS_SYS_ERRLIST
3213 sys_errlist[e]
a0d0e21e 3214#else
1e422769 3215 strerror(e)
a0d0e21e 3216#endif
1e422769 3217 ;
3218 if (!errmsg)
3219 break;
3220 if (instr(s, errmsg)) {
3221 SETERRNO(e,0);
3222 return 0;
3223 }
a0d0e21e 3224 }
748a9306 3225 SETERRNO(0,0);
a0d0e21e
LW		 3226#ifndef EACCES
3227#define EACCES EPERM
3228#endif
1e422769 3229 if (instr(s, "cannot make"))
748a9306 3230 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3231 else if (instr(s, "existing file"))
748a9306 3232 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3233 else if (instr(s, "ile exists"))
748a9306 3234 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3235 else if (instr(s, "non-exist"))
748a9306 3236 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3237 else if (instr(s, "does not exist"))
748a9306 3238 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3239 else if (instr(s, "not empty"))
748a9306 3240 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3241 else if (instr(s, "cannot access"))
748a9306 3242 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3243 else
748a9306 3244 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3245 return 0;
3246 }
3247 else { /* some mkdirs return no failure indication */
6b88bc9c 3248 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3249 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3250 anum = !anum;
3251 if (anum)
748a9306 3252 SETERRNO(0,0);
a0d0e21e 3253 else
748a9306 3254 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3255 }
3256 return anum;
3257 }
3258 else
3259 return 0;
3260}
3261#endif
3262
3263PP(pp_mkdir)
3264{
4e35701f 3265 djSP; dTARGET;
a0d0e21e
LW		 3266 int mode = POPi;
3267#ifndef HAS_MKDIR
3268 int oldumask;
3269#endif
2d8e6c8d
GS		 3270 STRLEN n_a;
3271 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3272
3273 TAINT_PROPER("mkdir");
3274#ifdef HAS_MKDIR
6ad3d225 3275 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3276#else
3277 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3278 oldumask = PerlLIO_umask(0);
3279 PerlLIO_umask(oldumask);
3280 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3281#endif
3282 RETURN;
3283}
3284
3285PP(pp_rmdir)
3286{
4e35701f 3287 djSP; dTARGET;
a0d0e21e 3288 char *tmps;
2d8e6c8d 3289 STRLEN n_a;
a0d0e21e 3290
2d8e6c8d 3291 tmps = POPpx;
a0d0e21e
LW		 3292 TAINT_PROPER("rmdir");
3293#ifdef HAS_RMDIR
6ad3d225 3294 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3295#else
3296 XPUSHi( dooneliner("rmdir", tmps) );
3297#endif
3298 RETURN;
3299}
3300
3301/* Directory calls. */
3302
3303PP(pp_open_dir)
3304{
4e35701f 3305 djSP;
a0d0e21e 3306#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3307 STRLEN n_a;
3308 char *dirname = POPpx;
a0d0e21e
LW		 3309 GV *gv = (GV*)POPs;
3310 register IO *io = GvIOn(gv);
3311
3312 if (!io)
3313 goto nope;
3314
3315 if (IoDIRP(io))
6ad3d225
GS		 3316 PerlDir_close(IoDIRP(io));
3317 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3318 goto nope;
3319
3320 RETPUSHYES;
3321nope:
3322 if (!errno)
748a9306 3323 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3324 RETPUSHUNDEF;
3325#else
22c35a8c 3326 DIE(PL_no_dir_func, "opendir");
a0d0e21e
LW		 3327#endif
3328}
3329
3330PP(pp_readdir)
3331{
4e35701f 3332 djSP;
a0d0e21e
LW		 3333#if defined(Direntry_t) && defined(HAS_READDIR)
3334#ifndef I_DIRENT
20ce7b12 3335 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3336#endif
3337 register Direntry_t *dp;
3338 GV *gv = (GV*)POPs;
3339 register IO *io = GvIOn(gv);
fb73857a 3340 SV *sv;
a0d0e21e
LW		 3341
3342 if (!io || !IoDIRP(io))
3343 goto nope;
3344
3345 if (GIMME == G_ARRAY) {
3346 /*SUPPRESS 560*/
6ad3d225 3347 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3348#ifdef DIRNAMLEN
79cb57f6 3349 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3350#else
fb73857a 3351 sv = newSVpv(dp->d_name, 0);
3352#endif
3353#ifndef INCOMPLETE_TAINTS
3354 SvTAINTED_on(sv);
a0d0e21e 3355#endif
fb73857a 3356 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3357 }
3358 }
3359 else {
6ad3d225 3360 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3361 goto nope;
3362#ifdef DIRNAMLEN
79cb57f6 3363 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3364#else
fb73857a 3365 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3366#endif
fb73857a 3367#ifndef INCOMPLETE_TAINTS
3368 SvTAINTED_on(sv);
3369#endif
3370 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3371 }
3372 RETURN;
3373
3374nope:
3375 if (!errno)
748a9306 3376 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3377 if (GIMME == G_ARRAY)
3378 RETURN;
3379 else
3380 RETPUSHUNDEF;
3381#else
22c35a8c 3382 DIE(PL_no_dir_func, "readdir");
a0d0e21e
LW		 3383#endif
3384}
3385
3386PP(pp_telldir)
3387{
4e35701f 3388 djSP; dTARGET;
a0d0e21e 3389#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3390 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3391 /* XXX netbsd still seemed to.
3392 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3393 --JHI 1999-Feb-02 */
3394# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3395 long telldir (DIR *);
dfe9444c 3396# endif
a0d0e21e
LW		 3397 GV *gv = (GV*)POPs;
3398 register IO *io = GvIOn(gv);
3399
3400 if (!io || !IoDIRP(io))
3401 goto nope;
3402
6ad3d225 3403 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3404 RETURN;
3405nope:
3406 if (!errno)
748a9306 3407 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3408 RETPUSHUNDEF;
3409#else
22c35a8c 3410 DIE(PL_no_dir_func, "telldir");
a0d0e21e
LW		 3411#endif
3412}
3413
3414PP(pp_seekdir)
3415{
4e35701f 3416 djSP;
a0d0e21e
LW		 3417#if defined(HAS_SEEKDIR) || defined(seekdir)
3418 long along = POPl;
3419 GV *gv = (GV*)POPs;
3420 register IO *io = GvIOn(gv);
3421
3422 if (!io || !IoDIRP(io))
3423 goto nope;
3424
6ad3d225 3425 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3426
3427 RETPUSHYES;
3428nope:
3429 if (!errno)
748a9306 3430 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3431 RETPUSHUNDEF;
3432#else
22c35a8c 3433 DIE(PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3434#endif
3435}
3436
3437PP(pp_rewinddir)
3438{
4e35701f 3439 djSP;
a0d0e21e
LW		 3440#if defined(HAS_REWINDDIR) || defined(rewinddir)
3441 GV *gv = (GV*)POPs;
3442 register IO *io = GvIOn(gv);
3443
3444 if (!io || !IoDIRP(io))
3445 goto nope;
3446
6ad3d225 3447 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3448 RETPUSHYES;
3449nope:
3450 if (!errno)
748a9306 3451 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3452 RETPUSHUNDEF;
3453#else
22c35a8c 3454 DIE(PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3455#endif
3456}
3457
3458PP(pp_closedir)
3459{
4e35701f 3460 djSP;
a0d0e21e
LW		 3461#if defined(Direntry_t) && defined(HAS_READDIR)
3462 GV *gv = (GV*)POPs;
3463 register IO *io = GvIOn(gv);
3464
3465 if (!io || !IoDIRP(io))
3466 goto nope;
3467
3468#ifdef VOID_CLOSEDIR
6ad3d225 3469 PerlDir_close(IoDIRP(io));
a0d0e21e 3470#else
6ad3d225 3471 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3472 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3473 goto nope;
748a9306 3474 }
a0d0e21e
LW		 3475#endif
3476 IoDIRP(io) = 0;
3477
3478 RETPUSHYES;
3479nope:
3480 if (!errno)
748a9306 3481 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3482 RETPUSHUNDEF;
3483#else
22c35a8c 3484 DIE(PL_no_dir_func, "closedir");
a0d0e21e
LW		 3485#endif
3486}
3487
3488/* Process control. */
3489
3490PP(pp_fork)
3491{
44a8e56a 3492#ifdef HAS_FORK
4e35701f 3493 djSP; dTARGET;
761237fe 3494 Pid_t childpid;
a0d0e21e
LW		 3495 GV *tmpgv;
3496
3497 EXTEND(SP, 1);
45bc9206 3498 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3499 childpid = fork();
3500 if (childpid < 0)
3501 RETSETUNDEF;
3502 if (!childpid) {
3503 /*SUPPRESS 560*/
3504 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3505 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3506 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3507 }
3508 PUSHi(childpid);
3509 RETURN;
3510#else
22c35a8c 3511 DIE(PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3512#endif
3513}
3514
3515PP(pp_wait)
3516{
8736538c 3517#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3518 djSP; dTARGET;
761237fe 3519 Pid_t childpid;
a0d0e21e 3520 int argflags;
a0d0e21e 3521
44a8e56a 3522 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3523 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3524 XPUSHi(childpid);
a0d0e21e
LW		 3525 RETURN;
3526#else
22c35a8c 3527 DIE(PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3528#endif
3529}
3530
3531PP(pp_waitpid)
3532{
8736538c 3533#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3534 djSP; dTARGET;
761237fe 3535 Pid_t childpid;
a0d0e21e
LW		 3536 int optype;
3537 int argflags;
a0d0e21e 3538
a0d0e21e
LW		 3539 optype = POPi;
3540 childpid = TOPi;
3541 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3542 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3543 SETi(childpid);
a0d0e21e
LW		 3544 RETURN;
3545#else
22c35a8c 3546 DIE(PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3547#endif
3548}
3549
3550PP(pp_system)
3551{
4e35701f 3552 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3553 I32 value;
761237fe 3554 Pid_t childpid;
a0d0e21e
LW		 3555 int result;
3556 int status;
ff68c719 3557 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3558 STRLEN n_a;
a0d0e21e 3559
a0d0e21e 3560 if (SP - MARK == 1) {
3280af22 3561 if (PL_tainting) {
2d8e6c8d 3562 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3563 TAINT_ENV();
3564 TAINT_PROPER("system");
3565 }
3566 }
45bc9206 3567 PERL_FLUSHALL_FOR_CHILD;
1e422769 3568#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3569 while ((childpid = vfork()) == -1) {
3570 if (errno != EAGAIN) {
3571 value = -1;
3572 SP = ORIGMARK;
3573 PUSHi(value);
3574 RETURN;
3575 }
3576 sleep(5);
3577 }
3578 if (childpid > 0) {
ff68c719 3579 rsignal_save(SIGINT, SIG_IGN, &ihand);
3580 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3581 do {
3582 result = wait4pid(childpid, &status, 0);
3583 } while (result == -1 && errno == EINTR);
ff68c719 3584 (void)rsignal_restore(SIGINT, &ihand);
3585 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3586 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3587 do_execfree(); /* free any memory child malloced on vfork */
3588 SP = ORIGMARK;
ff0cee69 3589 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3590 RETURN;
3591 }
533c011a 3592 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3593 SV *really = *++MARK;
3594 value = (I32)do_aexec(really, MARK, SP);
3595 }
3596 else if (SP - MARK != 1)
3597 value = (I32)do_aexec(Nullsv, MARK, SP);
3598 else {
2d8e6c8d 3599 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3600 }
6ad3d225 3601 PerlProc__exit(-1);
c3293030 3602#else /* ! FORK or VMS or OS/2 */
911d147d 3603 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3604 SV *really = *++MARK;
4e35701f 3605 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3606 }
3607 else if (SP - MARK != 1)
4e35701f 3608 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3609 else {
2d8e6c8d 3610 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3611 }
f86702cc 3612 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3613 do_execfree();
3614 SP = ORIGMARK;
ff0cee69 3615 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3616#endif /* !FORK or VMS */
3617 RETURN;
3618}
3619
3620PP(pp_exec)
3621{
4e35701f 3622 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3623 I32 value;
2d8e6c8d 3624 STRLEN n_a;
a0d0e21e 3625
45bc9206 3626 PERL_FLUSHALL_FOR_CHILD;
533c011a 3627 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3628 SV *really = *++MARK;
3629 value = (I32)do_aexec(really, MARK, SP);
3630 }
3631 else if (SP - MARK != 1)
3632#ifdef VMS
3633 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3634#else
092bebab
JH		 3635# ifdef __OPEN_VM
3636 {
3637 (void ) do_aspawn(Nullsv, MARK, SP);
3638 value = 0;
3639 }
3640# else
a0d0e21e 3641 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3642# endif
a0d0e21e
LW		 3643#endif
3644 else {
3280af22 3645 if (PL_tainting) {
2d8e6c8d 3646 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3647 TAINT_ENV();
3648 TAINT_PROPER("exec");
3649 }
3650#ifdef VMS
2d8e6c8d 3651 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3652#else
092bebab 3653# ifdef __OPEN_VM
2d8e6c8d 3654 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3655 value = 0;
3656# else
2d8e6c8d 3657 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3658# endif
a0d0e21e
LW		 3659#endif
3660 }
3661 SP = ORIGMARK;
3662 PUSHi(value);
3663 RETURN;
3664}
3665
3666PP(pp_kill)
3667{
4e35701f 3668 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3669 I32 value;
3670#ifdef HAS_KILL
533c011a 3671 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3672 SP = MARK;
3673 PUSHi(value);
3674 RETURN;
3675#else
22c35a8c 3676 DIE(PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3677#endif
3678}
3679
3680PP(pp_getppid)
3681{
3682#ifdef HAS_GETPPID
4e35701f 3683 djSP; dTARGET;
a0d0e21e
LW		 3684 XPUSHi( getppid() );
3685 RETURN;
3686#else
22c35a8c 3687 DIE(PL_no_func, "getppid");
a0d0e21e
LW		 3688#endif
3689}
3690
3691PP(pp_getpgrp)
3692{
3693#ifdef HAS_GETPGRP
4e35701f 3694 djSP; dTARGET;
a0d0e21e
LW		 3695 int pid;
3696 I32 value;
3697
3698 if (MAXARG < 1)
3699 pid = 0;
3700 else
3701 pid = SvIVx(POPs);
c3293030
IZ		 3702#ifdef BSD_GETPGRP
3703 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3704#else
aa689395 3705 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3706 DIE("POSIX getpgrp can't take an argument");
3707 value = (I32)getpgrp();
3708#endif
3709 XPUSHi(value);
3710 RETURN;
3711#else
22c35a8c 3712 DIE(PL_no_func, "getpgrp()");
a0d0e21e
LW		 3713#endif
3714}
3715
3716PP(pp_setpgrp)
3717{
3718#ifdef HAS_SETPGRP
4e35701f 3719 djSP; dTARGET;
a0d0e21e
LW		 3720 int pgrp;
3721 int pid;
3722 if (MAXARG < 2) {
3723 pgrp = 0;
3724 pid = 0;
3725 }
3726 else {
3727 pgrp = POPi;
3728 pid = TOPi;
3729 }
3730
3731 TAINT_PROPER("setpgrp");
c3293030
IZ		 3732#ifdef BSD_SETPGRP
3733 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3734#else
c90c0ff4 3735 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3736 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3737 SETi( setpgrp() >= 0 );
3738#endif /* USE_BSDPGRP */
3739 RETURN;
3740#else
22c35a8c 3741 DIE(PL_no_func, "setpgrp()");
a0d0e21e
LW		 3742#endif
3743}
3744
3745PP(pp_getpriority)
3746{
4e35701f 3747 djSP; dTARGET;
a0d0e21e
LW		 3748 int which;
3749 int who;
3750#ifdef HAS_GETPRIORITY
3751 who = POPi;
3752 which = TOPi;
3753 SETi( getpriority(which, who) );
3754 RETURN;
3755#else
22c35a8c 3756 DIE(PL_no_func, "getpriority()");
a0d0e21e
LW		 3757#endif
3758}
3759
3760PP(pp_setpriority)
3761{
4e35701f 3762 djSP; dTARGET;
a0d0e21e
LW		 3763 int which;
3764 int who;
3765 int niceval;
3766#ifdef HAS_SETPRIORITY
3767 niceval = POPi;
3768 who = POPi;
3769 which = TOPi;
3770 TAINT_PROPER("setpriority");
3771 SETi( setpriority(which, who, niceval) >= 0 );
3772 RETURN;
3773#else
22c35a8c 3774 DIE(PL_no_func, "setpriority()");
a0d0e21e
LW		 3775#endif
3776}
3777
3778/* Time calls. */
3779
3780PP(pp_time)
3781{
4e35701f 3782 djSP; dTARGET;
cbdc8872 3783#ifdef BIG_TIME
3784 XPUSHn( time(Null(Time_t*)) );
3785#else
a0d0e21e 3786 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3787#endif
a0d0e21e
LW		 3788 RETURN;
3789}
3790
cd52b7b2 3791/* XXX The POSIX name is CLK_TCK; it is to be preferred
3792 to HZ. Probably. For now, assume that if the system
3793 defines HZ, it does so correctly. (Will this break
3794 on VMS?)
3795 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3796 it's supported. --AD 9/96.
3797*/
3798
a0d0e21e 3799#ifndef HZ
cd52b7b2 3800# ifdef CLK_TCK
3801# define HZ CLK_TCK
3802# else
3803# define HZ 60
3804# endif
a0d0e21e
LW		 3805#endif
3806
3807PP(pp_tms)
3808{
4e35701f 3809 djSP;
a0d0e21e 3810
55497cff 3811#ifndef HAS_TIMES
a0d0e21e
LW		 3812 DIE("times not implemented");
3813#else
3814 EXTEND(SP, 4);
3815
3816#ifndef VMS
3280af22 3817 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3818#else
6b88bc9c 3819 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3820 /* struct tms, though same data */
3821 /* is returned. */
a0d0e21e
LW		 3822#endif
3823
3280af22 3824 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3825 if (GIMME == G_ARRAY) {
3280af22
NIS		 3826 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3827 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3828 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3829 }
3830 RETURN;
55497cff 3831#endif /* HAS_TIMES */
a0d0e21e
LW		 3832}
3833
3834PP(pp_localtime)
3835{
3836 return pp_gmtime(ARGS);
3837}
3838
3839PP(pp_gmtime)
3840{
4e35701f 3841 djSP;
a0d0e21e
LW		 3842 Time_t when;
3843 struct tm *tmbuf;
3844 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3845 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3846 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3847
3848 if (MAXARG < 1)
3849 (void)time(&when);
3850 else
cbdc8872 3851#ifdef BIG_TIME
3852 when = (Time_t)SvNVx(POPs);
3853#else
a0d0e21e 3854 when = (Time_t)SvIVx(POPs);
cbdc8872 3855#endif
a0d0e21e 3856
533c011a 3857 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3858 tmbuf = localtime(&when);
3859 else
3860 tmbuf = gmtime(&when);
3861
3862 EXTEND(SP, 9);
bbce6d69 3863 EXTEND_MORTAL(9);
a0d0e21e
LW		 3864 if (GIMME != G_ARRAY) {
3865 dTARGET;
46fc3d4c 3866 SV *tsv;
a0d0e21e
LW		 3867 if (!tmbuf)
3868 RETPUSHUNDEF;
46fc3d4c 3869 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3870 dayname[tmbuf->tm_wday],
3871 monname[tmbuf->tm_mon],
3872 tmbuf->tm_mday,
3873 tmbuf->tm_hour,
3874 tmbuf->tm_min,
3875 tmbuf->tm_sec,
3876 tmbuf->tm_year + 1900);
3877 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3878 }
3879 else if (tmbuf) {
3880 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3881 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3882 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3883 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3884 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3885 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3886 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3887 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3888 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3889 }
3890 RETURN;
3891}
3892
3893PP(pp_alarm)
3894{
4e35701f 3895 djSP; dTARGET;
a0d0e21e
LW		 3896 int anum;
3897#ifdef HAS_ALARM
3898 anum = POPi;
3899 anum = alarm((unsigned int)anum);
3900 EXTEND(SP, 1);
3901 if (anum < 0)
3902 RETPUSHUNDEF;
3903 PUSHi((I32)anum);
3904 RETURN;
3905#else
22c35a8c 3906 DIE(PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 3907#endif
3908}
3909
3910PP(pp_sleep)
3911{
4e35701f 3912 djSP; dTARGET;
a0d0e21e
LW		 3913 I32 duration;
3914 Time_t lasttime;
3915 Time_t when;
3916
3917 (void)time(&lasttime);
3918 if (MAXARG < 1)
76e3520e 3919 PerlProc_pause();
a0d0e21e
LW		 3920 else {
3921 duration = POPi;
76e3520e 3922 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3923 }
3924 (void)time(&when);
3925 XPUSHi(when - lasttime);
3926 RETURN;
3927}
3928
3929/* Shared memory. */
3930
3931PP(pp_shmget)
3932{
3933 return pp_semget(ARGS);
3934}
3935
3936PP(pp_shmctl)
3937{
3938 return pp_semctl(ARGS);
3939}
3940
3941PP(pp_shmread)
3942{
3943 return pp_shmwrite(ARGS);
3944}
3945
3946PP(pp_shmwrite)
3947{
3948#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3949 djSP; dMARK; dTARGET;
533c011a 3950 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 3951 SP = MARK;
3952 PUSHi(value);
3953 RETURN;
3954#else
748a9306 3955 return pp_semget(ARGS);
a0d0e21e
LW		 3956#endif
3957}
3958
3959/* Message passing. */
3960
3961PP(pp_msgget)
3962{
3963 return pp_semget(ARGS);
3964}
3965
3966PP(pp_msgctl)
3967{
3968 return pp_semctl(ARGS);
3969}
3970
3971PP(pp_msgsnd)
3972{
3973#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3974 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3975 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3976 SP = MARK;
3977 PUSHi(value);
3978 RETURN;
3979#else
748a9306 3980 return pp_semget(ARGS);
a0d0e21e
LW		 3981#endif
3982}
3983
3984PP(pp_msgrcv)
3985{
3986#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3987 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3988 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3989 SP = MARK;
3990 PUSHi(value);
3991 RETURN;
3992#else
748a9306 3993 return pp_semget(ARGS);
a0d0e21e
LW		 3994#endif
3995}
3996
3997/* Semaphores. */
3998
3999PP(pp_semget)
4000{
4001#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4002 djSP; dMARK; dTARGET;
533c011a 4003 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4004 SP = MARK;
4005 if (anum == -1)
4006 RETPUSHUNDEF;
4007 PUSHi(anum);
4008 RETURN;
4009#else
4010 DIE("System V IPC is not implemented on this machine");
4011#endif
4012}
4013
4014PP(pp_semctl)
4015{
4016#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4017 djSP; dMARK; dTARGET;
533c011a 4018 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4019 SP = MARK;
4020 if (anum == -1)
4021 RETSETUNDEF;
4022 if (anum != 0) {
4023 PUSHi(anum);
4024 }
4025 else {
8903cb82 4026 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4027 }
4028 RETURN;
4029#else
748a9306 4030 return pp_semget(ARGS);
a0d0e21e
LW		 4031#endif
4032}
4033
4034PP(pp_semop)
4035{
4036#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4037 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4038 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4039 SP = MARK;
4040 PUSHi(value);
4041 RETURN;
4042#else
748a9306 4043 return pp_semget(ARGS);
a0d0e21e
LW		 4044#endif
4045}
4046
4047/* Get system info. */
4048
4049PP(pp_ghbyname)
4050{
693762b4 4051#ifdef HAS_GETHOSTBYNAME
a0d0e21e
LW		 4052 return pp_ghostent(ARGS);
4053#else
22c35a8c 4054 DIE(PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4055#endif
4056}
4057
4058PP(pp_ghbyaddr)
4059{
693762b4 4060#ifdef HAS_GETHOSTBYADDR
a0d0e21e
LW		 4061 return pp_ghostent(ARGS);
4062#else
22c35a8c 4063 DIE(PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4064#endif
4065}
4066
4067PP(pp_ghostent)
4068{
4e35701f 4069 djSP;
693762b4 4070#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4071 I32 which = PL_op->op_type;
a0d0e21e
LW		 4072 register char **elem;
4073 register SV *sv;
dc45a647 4074#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4075 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4076 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4077 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4078#endif
4079 struct hostent *hent;
4080 unsigned long len;
2d8e6c8d 4081 STRLEN n_a;
a0d0e21e
LW		 4082
4083 EXTEND(SP, 10);
dc45a647
MB		 4084 if (which == OP_GHBYNAME)
4085#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4086 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4087#else
22c35a8c 4088 DIE(PL_no_sock_func, "gethostbyname");
dc45a647 4089#endif
a0d0e21e 4090 else if (which == OP_GHBYADDR) {
dc45a647 4091#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4092 int addrtype = POPi;
748a9306 4093 SV *addrsv = POPs;
a0d0e21e 4094 STRLEN addrlen;
4599a1de 4095 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4096
4599a1de 4097 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4098#else
22c35a8c 4099 DIE(PL_no_sock_func, "gethostbyaddr");
dc45a647 4100#endif
a0d0e21e
LW		 4101 }
4102 else
4103#ifdef HAS_GETHOSTENT
6ad3d225 4104 hent = PerlSock_gethostent();
a0d0e21e 4105#else
22c35a8c 4106 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4107#endif
4108
4109#ifdef HOST_NOT_FOUND
4110 if (!hent)
f86702cc 4111 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4112#endif
4113
4114 if (GIMME != G_ARRAY) {
4115 PUSHs(sv = sv_newmortal());
4116 if (hent) {
4117 if (which == OP_GHBYNAME) {
fd0af264 4118 if (hent->h_addr)
4119 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4120 }
4121 else
4122 sv_setpv(sv, (char*)hent->h_name);
4123 }
4124 RETURN;
4125 }
4126
4127 if (hent) {
3280af22 4128 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4129 sv_setpv(sv, (char*)hent->h_name);
3280af22 4130 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4131 for (elem = hent->h_aliases; elem && *elem; elem++) {
4132 sv_catpv(sv, *elem);
4133 if (elem[1])
4134 sv_catpvn(sv, " ", 1);
4135 }
3280af22 4136 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4137 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4138 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4139 len = hent->h_length;
1e422769 4140 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4141#ifdef h_addr
4142 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4143 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4144 sv_setpvn(sv, *elem, len);
4145 }
4146#else
6b88bc9c 4147 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4148 if (hent->h_addr)
4149 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4150#endif /* h_addr */
4151 }
4152 RETURN;
4153#else
22c35a8c 4154 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4155#endif
4156}
4157
4158PP(pp_gnbyname)
4159{
693762b4 4160#ifdef HAS_GETNETBYNAME
a0d0e21e
LW		 4161 return pp_gnetent(ARGS);
4162#else
22c35a8c 4163 DIE(PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4164#endif
4165}
4166
4167PP(pp_gnbyaddr)
4168{
693762b4 4169#ifdef HAS_GETNETBYADDR
a0d0e21e
LW		 4170 return pp_gnetent(ARGS);
4171#else
22c35a8c 4172 DIE(PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4173#endif
4174}
4175
4176PP(pp_gnetent)
4177{
4e35701f 4178 djSP;
693762b4 4179#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4180 I32 which = PL_op->op_type;
a0d0e21e
LW		 4181 register char **elem;
4182 register SV *sv;
dc45a647
MB		 4183#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4184 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4185 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4186 struct netent *PerlSock_getnetent(void);
8ac85365 4187#endif
a0d0e21e 4188 struct netent *nent;
2d8e6c8d 4189 STRLEN n_a;
a0d0e21e
LW		 4190
4191 if (which == OP_GNBYNAME)
dc45a647 4192#ifdef HAS_GETNETBYNAME
2d8e6c8d 4193 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4194#else
22c35a8c 4195 DIE(PL_no_sock_func, "getnetbyname");
dc45a647 4196#endif
a0d0e21e 4197 else if (which == OP_GNBYADDR) {
dc45a647 4198#ifdef HAS_GETNETBYADDR
a0d0e21e 4199 int addrtype = POPi;
4599a1de 4200 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4201 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4202#else
22c35a8c 4203 DIE(PL_no_sock_func, "getnetbyaddr");
dc45a647 4204#endif
a0d0e21e
LW		 4205 }
4206 else
dc45a647 4207#ifdef HAS_GETNETENT
76e3520e 4208 nent = PerlSock_getnetent();
dc45a647 4209#else
22c35a8c 4210 DIE(PL_no_sock_func, "getnetent");
dc45a647 4211#endif
a0d0e21e
LW		 4212
4213 EXTEND(SP, 4);
4214 if (GIMME != G_ARRAY) {
4215 PUSHs(sv = sv_newmortal());
4216 if (nent) {
4217 if (which == OP_GNBYNAME)
1e422769 4218 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4219 else
4220 sv_setpv(sv, nent->n_name);
4221 }
4222 RETURN;
4223 }
4224
4225 if (nent) {
3280af22 4226 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4227 sv_setpv(sv, nent->n_name);
3280af22 4228 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4229 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4230 sv_catpv(sv, *elem);
4231 if (elem[1])
4232 sv_catpvn(sv, " ", 1);
4233 }
3280af22 4234 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4235 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4236 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4237 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4238 }
4239
4240 RETURN;
4241#else
22c35a8c 4242 DIE(PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4243#endif
4244}
4245
4246PP(pp_gpbyname)
4247{
693762b4 4248#ifdef HAS_GETPROTOBYNAME
a0d0e21e
LW		 4249 return pp_gprotoent(ARGS);
4250#else
22c35a8c 4251 DIE(PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4252#endif
4253}
4254
4255PP(pp_gpbynumber)
4256{
693762b4 4257#ifdef HAS_GETPROTOBYNUMBER
a0d0e21e
LW		 4258 return pp_gprotoent(ARGS);
4259#else
22c35a8c 4260 DIE(PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4261#endif
4262}
4263
4264PP(pp_gprotoent)
4265{
4e35701f 4266 djSP;
693762b4 4267#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4268 I32 which = PL_op->op_type;
a0d0e21e 4269 register char **elem;
8ac85365 4270 register SV *sv;
dc45a647 4271#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4272 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4273 struct protoent *PerlSock_getprotobynumber(int);
4274 struct protoent *PerlSock_getprotoent(void);
8ac85365 4275#endif
a0d0e21e 4276 struct protoent *pent;
2d8e6c8d 4277 STRLEN n_a;
a0d0e21e
LW		 4278
4279 if (which == OP_GPBYNAME)
e5c9fcd0 4280#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4281 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4282#else
22c35a8c 4283 DIE(PL_no_sock_func, "getprotobyname");
e5c9fcd0 4284#endif
a0d0e21e 4285 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4286#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4287 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4288#else
22c35a8c 4289 DIE(PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4290#endif
a0d0e21e 4291 else
e5c9fcd0 4292#ifdef HAS_GETPROTOENT
6ad3d225 4293 pent = PerlSock_getprotoent();
e5c9fcd0 4294#else
22c35a8c 4295 DIE(PL_no_sock_func, "getprotoent");
e5c9fcd0 4296#endif
a0d0e21e
LW		 4297
4298 EXTEND(SP, 3);
4299 if (GIMME != G_ARRAY) {
4300 PUSHs(sv = sv_newmortal());
4301 if (pent) {
4302 if (which == OP_GPBYNAME)
1e422769 4303 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4304 else
4305 sv_setpv(sv, pent->p_name);
4306 }
4307 RETURN;
4308 }
4309
4310 if (pent) {
3280af22 4311 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4312 sv_setpv(sv, pent->p_name);
3280af22 4313 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4314 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4315 sv_catpv(sv, *elem);
4316 if (elem[1])
4317 sv_catpvn(sv, " ", 1);
4318 }
3280af22 4319 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4320 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4321 }
4322
4323 RETURN;
4324#else
22c35a8c 4325 DIE(PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4326#endif
4327}
4328
4329PP(pp_gsbyname)
4330{
9ec75305 4331#ifdef HAS_GETSERVBYNAME
a0d0e21e
LW		 4332 return pp_gservent(ARGS);
4333#else
22c35a8c 4334 DIE(PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4335#endif
4336}
4337
4338PP(pp_gsbyport)
4339{
9ec75305 4340#ifdef HAS_GETSERVBYPORT
a0d0e21e
LW		 4341 return pp_gservent(ARGS);
4342#else
22c35a8c 4343 DIE(PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4344#endif
4345}
4346
4347PP(pp_gservent)
4348{
4e35701f 4349 djSP;
693762b4 4350#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4351 I32 which = PL_op->op_type;
a0d0e21e
LW		 4352 register char **elem;
4353 register SV *sv;
dc45a647 4354#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4355 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4356 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4357 struct servent *PerlSock_getservent(void);
8ac85365 4358#endif
a0d0e21e 4359 struct servent *sent;
2d8e6c8d 4360 STRLEN n_a;
a0d0e21e
LW		 4361
4362 if (which == OP_GSBYNAME) {
dc45a647 4363#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4364 char *proto = POPpx;
4365 char *name = POPpx;
a0d0e21e
LW		 4366
4367 if (proto && !*proto)
4368 proto = Nullch;
4369
6ad3d225 4370 sent = PerlSock_getservbyname(name, proto);
dc45a647 4371#else
22c35a8c 4372 DIE(PL_no_sock_func, "getservbyname");
dc45a647 4373#endif
a0d0e21e
LW		 4374 }
4375 else if (which == OP_GSBYPORT) {
dc45a647 4376#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4377 char *proto = POPpx;
36477c24 4378 unsigned short port = POPu;
a0d0e21e 4379
36477c24 4380#ifdef HAS_HTONS
6ad3d225 4381 port = PerlSock_htons(port);
36477c24 4382#endif
6ad3d225 4383 sent = PerlSock_getservbyport(port, proto);
dc45a647 4384#else
22c35a8c 4385 DIE(PL_no_sock_func, "getservbyport");
dc45a647 4386#endif
a0d0e21e
LW		 4387 }
4388 else
e5c9fcd0 4389#ifdef HAS_GETSERVENT
6ad3d225 4390 sent = PerlSock_getservent();
e5c9fcd0 4391#else
22c35a8c 4392 DIE(PL_no_sock_func, "getservent");
e5c9fcd0 4393#endif
a0d0e21e
LW		 4394
4395 EXTEND(SP, 4);
4396 if (GIMME != G_ARRAY) {
4397 PUSHs(sv = sv_newmortal());
4398 if (sent) {
4399 if (which == OP_GSBYNAME) {
4400#ifdef HAS_NTOHS
6ad3d225 4401 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4402#else
1e422769 4403 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4404#endif
4405 }
4406 else
4407 sv_setpv(sv, sent->s_name);
4408 }
4409 RETURN;
4410 }
4411
4412 if (sent) {
3280af22 4413 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4414 sv_setpv(sv, sent->s_name);
3280af22 4415 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4416 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4417 sv_catpv(sv, *elem);
4418 if (elem[1])
4419 sv_catpvn(sv, " ", 1);
4420 }
3280af22 4421 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4422#ifdef HAS_NTOHS
76e3520e 4423 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4424#else
1e422769 4425 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4426#endif
3280af22 4427 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4428 sv_setpv(sv, sent->s_proto);
4429 }
4430
4431 RETURN;
4432#else
22c35a8c 4433 DIE(PL_no_sock_func, "getservent");
a0d0e21e
LW		 4434#endif
4435}
4436
4437PP(pp_shostent)
4438{
4e35701f 4439 djSP;
693762b4 4440#ifdef HAS_SETHOSTENT
76e3520e 4441 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4442 RETSETYES;
4443#else
22c35a8c 4444 DIE(PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4445#endif
4446}
4447
4448PP(pp_snetent)
4449{
4e35701f 4450 djSP;
693762b4 4451#ifdef HAS_SETNETENT
76e3520e 4452 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4453 RETSETYES;
4454#else
22c35a8c 4455 DIE(PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4456#endif
4457}
4458
4459PP(pp_sprotoent)
4460{
4e35701f 4461 djSP;
693762b4 4462#ifdef HAS_SETPROTOENT
76e3520e 4463 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4464 RETSETYES;
4465#else
22c35a8c 4466 DIE(PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4467#endif
4468}
4469
4470PP(pp_sservent)
4471{
4e35701f 4472 djSP;
693762b4 4473#ifdef HAS_SETSERVENT
76e3520e 4474 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4475 RETSETYES;
4476#else
22c35a8c 4477 DIE(PL_no_sock_func, "setservent");
a0d0e21e
LW		 4478#endif
4479}
4480
4481PP(pp_ehostent)
4482{
4e35701f 4483 djSP;
693762b4 4484#ifdef HAS_ENDHOSTENT
76e3520e 4485 PerlSock_endhostent();
924508f0 4486 EXTEND(SP,1);
a0d0e21e
LW		 4487 RETPUSHYES;
4488#else
22c35a8c 4489 DIE(PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4490#endif
4491}
4492
4493PP(pp_enetent)
4494{
4e35701f 4495 djSP;
693762b4 4496#ifdef HAS_ENDNETENT
76e3520e 4497 PerlSock_endnetent();
924508f0 4498 EXTEND(SP,1);
a0d0e21e
LW		 4499 RETPUSHYES;
4500#else
22c35a8c 4501 DIE(PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4502#endif
4503}
4504
4505PP(pp_eprotoent)
4506{
4e35701f 4507 djSP;
693762b4 4508#ifdef HAS_ENDPROTOENT
76e3520e 4509 PerlSock_endprotoent();
924508f0 4510 EXTEND(SP,1);
a0d0e21e
LW		 4511 RETPUSHYES;
4512#else
22c35a8c 4513 DIE(PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4514#endif
4515}
4516
4517PP(pp_eservent)
4518{
4e35701f 4519 djSP;
693762b4 4520#ifdef HAS_ENDSERVENT
76e3520e 4521 PerlSock_endservent();
924508f0 4522 EXTEND(SP,1);
a0d0e21e
LW		 4523 RETPUSHYES;
4524#else
22c35a8c 4525 DIE(PL_no_sock_func, "endservent");
a0d0e21e
LW		 4526#endif
4527}
4528
4529PP(pp_gpwnam)
4530{
4531#ifdef HAS_PASSWD
4532 return pp_gpwent(ARGS);
4533#else
22c35a8c 4534 DIE(PL_no_func, "getpwnam");
a0d0e21e
LW		 4535#endif
4536}
4537
4538PP(pp_gpwuid)
4539{
4540#ifdef HAS_PASSWD
4541 return pp_gpwent(ARGS);
4542#else
22c35a8c 4543 DIE(PL_no_func, "getpwuid");
a0d0e21e
LW		 4544#endif
4545}
4546
4547PP(pp_gpwent)
4548{
4e35701f 4549 djSP;
28e8609d 4550#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
533c011a 4551 I32 which = PL_op->op_type;
a0d0e21e
LW		 4552 register SV *sv;
4553 struct passwd *pwent;
2d8e6c8d 4554 STRLEN n_a;
8c0bfa08 4555#ifdef HAS_GETSPENT
eff96b52 4556 struct spwd *spwent = NULL;
8c0bfa08 4557#endif
a0d0e21e
LW		 4558
4559 if (which == OP_GPWNAM)
2d8e6c8d 4560 pwent = getpwnam(POPpx);
a0d0e21e
LW		 4561 else if (which == OP_GPWUID)
4562 pwent = getpwuid(POPi);
4563 else
4564 pwent = (struct passwd *)getpwent();
4565
f1066039 4566#ifdef HAS_GETSPNAM
eff96b52
GS		 4567 if (which == OP_GPWNAM) {
4568 if (pwent)
4569 spwent = getspnam(pwent->pw_name);
4570 }
f1066039 4571# ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
eff96b52
GS		 4572 else if (which == OP_GPWUID) {
4573 if (pwent)
4574 spwent = getspnam(pwent->pw_name);
4575 }
f1066039 4576# endif
eff96b52
GS		 4577 else
4578 spwent = (struct spwd *)getspent();
8c0bfa08
PB		 4579#endif
4580
a0d0e21e
LW		 4581 EXTEND(SP, 10);
4582 if (GIMME != G_ARRAY) {
4583 PUSHs(sv = sv_newmortal());
4584 if (pwent) {
4585 if (which == OP_GPWNAM)
1e422769 4586 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4587 else
4588 sv_setpv(sv, pwent->pw_name);
4589 }
4590 RETURN;
4591 }
4592
4593 if (pwent) {
3280af22 4594 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4595 sv_setpv(sv, pwent->pw_name);
6ee623d5 4596
3280af22 4597 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4598#ifdef PWPASSWD
f1066039 4599# ifdef HAS_GETSPENT
8c0bfa08
PB		 4600 if (spwent)
4601 sv_setpv(sv, spwent->sp_pwdp);
4602 else
4603 sv_setpv(sv, pwent->pw_passwd);
f1066039 4604# else
a0d0e21e 4605 sv_setpv(sv, pwent->pw_passwd);
f1066039 4606# endif
8c0bfa08 4607#endif
6ee623d5 4608
3280af22 4609 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4610 sv_setiv(sv, (IV)pwent->pw_uid);
6ee623d5 4611
3280af22 4612 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4613 sv_setiv(sv, (IV)pwent->pw_gid);
6ee623d5
GS		 4614
4615 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4616 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4617#ifdef PWCHANGE
1e422769 4618 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4619#else
6ee623d5 4620# ifdef PWQUOTA
1e422769 4621 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4622# else
4623# ifdef PWAGE
a0d0e21e 4624 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4625# endif
4626# endif
a0d0e21e 4627#endif
6ee623d5
GS		 4628
4629 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4630 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4631#ifdef PWCLASS
4632 sv_setpv(sv, pwent->pw_class);
4633#else
6ee623d5 4634# ifdef PWCOMMENT
a0d0e21e 4635 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4636# endif
a0d0e21e 4637#endif
6ee623d5 4638
3280af22 4639 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4640#ifdef PWGECOS
a0d0e21e 4641 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4642#endif
fb73857a 4643#ifndef INCOMPLETE_TAINTS
d2719217 4644 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4645 SvTAINTED_on(sv);
4646#endif
6ee623d5 4647
3280af22 4648 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4649 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4650
3280af22 4651 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4652 sv_setpv(sv, pwent->pw_shell);
6ee623d5 4653
a0d0e21e 4654#ifdef PWEXPIRE
6b88bc9c 4655 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4656 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4657#endif
4658 }
4659 RETURN;
4660#else
22c35a8c 4661 DIE(PL_no_func, "getpwent");
a0d0e21e
LW		 4662#endif
4663}
4664
4665PP(pp_spwent)
4666{
4e35701f 4667 djSP;
28e8609d 4668#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
a0d0e21e 4669 setpwent();
f1066039 4670# ifdef HAS_SETSPENT
8c0bfa08 4671 setspent();
f1066039 4672# endif
a0d0e21e
LW		 4673 RETPUSHYES;
4674#else
22c35a8c 4675 DIE(PL_no_func, "setpwent");
a0d0e21e
LW		 4676#endif
4677}
4678
4679PP(pp_epwent)
4680{
4e35701f 4681 djSP;
28e8609d 4682#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e 4683 endpwent();
f1066039 4684# ifdef HAS_ENDSPENT
8c0bfa08 4685 endspent();
f1066039 4686# endif
a0d0e21e
LW		 4687 RETPUSHYES;
4688#else
22c35a8c 4689 DIE(PL_no_func, "endpwent");
a0d0e21e
LW		 4690#endif
4691}
4692
4693PP(pp_ggrnam)
4694{
4695#ifdef HAS_GROUP
4696 return pp_ggrent(ARGS);
4697#else
22c35a8c 4698 DIE(PL_no_func, "getgrnam");
a0d0e21e
LW		 4699#endif
4700}
4701
4702PP(pp_ggrgid)
4703{
4704#ifdef HAS_GROUP
4705 return pp_ggrent(ARGS);
4706#else
22c35a8c 4707 DIE(PL_no_func, "getgrgid");
a0d0e21e
LW		 4708#endif
4709}
4710
4711PP(pp_ggrent)
4712{
4e35701f 4713 djSP;
28e8609d 4714#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
533c011a 4715 I32 which = PL_op->op_type;
a0d0e21e
LW		 4716 register char **elem;
4717 register SV *sv;
4718 struct group *grent;
2d8e6c8d 4719 STRLEN n_a;
a0d0e21e
LW		 4720
4721 if (which == OP_GGRNAM)
2d8e6c8d 4722 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 4723 else if (which == OP_GGRGID)
4724 grent = (struct group *)getgrgid(POPi);
4725 else
4726 grent = (struct group *)getgrent();
4727
4728 EXTEND(SP, 4);
4729 if (GIMME != G_ARRAY) {
4730 PUSHs(sv = sv_newmortal());
4731 if (grent) {
4732 if (which == OP_GGRNAM)
1e422769 4733 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4734 else
4735 sv_setpv(sv, grent->gr_name);
4736 }
4737 RETURN;
4738 }
4739
4740 if (grent) {
3280af22 4741 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4742 sv_setpv(sv, grent->gr_name);
28e8609d 4743
3280af22 4744 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4745#ifdef GRPASSWD
a0d0e21e 4746 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4747#endif
4748
3280af22 4749 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4750 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4751
3280af22 4752 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4753 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4754 sv_catpv(sv, *elem);
4755 if (elem[1])
4756 sv_catpvn(sv, " ", 1);
4757 }
4758 }
4759
4760 RETURN;
4761#else
22c35a8c 4762 DIE(PL_no_func, "getgrent");
a0d0e21e
LW		 4763#endif
4764}
4765
4766PP(pp_sgrent)
4767{
4e35701f 4768 djSP;
28e8609d 4769#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 4770 setgrent();
4771 RETPUSHYES;
4772#else
22c35a8c 4773 DIE(PL_no_func, "setgrent");
a0d0e21e
LW		 4774#endif
4775}
4776
4777PP(pp_egrent)
4778{
4e35701f 4779 djSP;
28e8609d 4780#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 4781 endgrent();
4782 RETPUSHYES;
4783#else
22c35a8c 4784 DIE(PL_no_func, "endgrent");
a0d0e21e
LW		 4785#endif
4786}
4787
4788PP(pp_getlogin)
4789{
4e35701f 4790 djSP; dTARGET;
a0d0e21e
LW		 4791#ifdef HAS_GETLOGIN
4792 char *tmps;
4793 EXTEND(SP, 1);
76e3520e 4794 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 4795 RETPUSHUNDEF;
4796 PUSHp(tmps, strlen(tmps));
4797 RETURN;
4798#else
22c35a8c 4799 DIE(PL_no_func, "getlogin");
a0d0e21e
LW		 4800#endif
4801}
4802
4803/* Miscellaneous. */
4804
4805PP(pp_syscall)
4806{
d2719217 4807#ifdef HAS_SYSCALL
4e35701f 4808 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4809 register I32 items = SP - MARK;
4810 unsigned long a[20];
4811 register I32 i = 0;
4812 I32 retval = -1;
748a9306 4813 MAGIC *mg;
2d8e6c8d 4814 STRLEN n_a;
a0d0e21e 4815
3280af22 4816 if (PL_tainting) {
a0d0e21e 4817 while (++MARK <= SP) {
bbce6d69 4818 if (SvTAINTED(*MARK)) {
4819 TAINT;
4820 break;
4821 }
a0d0e21e
LW		 4822 }
4823 MARK = ORIGMARK;
4824 TAINT_PROPER("syscall");
4825 }
4826
4827 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4828 * or where sizeof(long) != sizeof(char*). But such machines will
4829 * not likely have syscall implemented either, so who cares?
4830 */
4831 while (++MARK <= SP) {
4832 if (SvNIOK(*MARK) || !i)
4833 a[i++] = SvIV(*MARK);
3280af22 4834 else if (*MARK == &PL_sv_undef)
748a9306
LW		 4835 a[i++] = 0;
4836 else
2d8e6c8d 4837 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 4838 if (i > 15)
4839 break;
4840 }
4841 switch (items) {
4842 default:
4843 DIE("Too many args to syscall");
4844 case 0:
4845 DIE("Too few args to syscall");
4846 case 1:
4847 retval = syscall(a[0]);
4848 break;
4849 case 2:
4850 retval = syscall(a[0],a[1]);
4851 break;
4852 case 3:
4853 retval = syscall(a[0],a[1],a[2]);
4854 break;
4855 case 4:
4856 retval = syscall(a[0],a[1],a[2],a[3]);
4857 break;
4858 case 5:
4859 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4860 break;
4861 case 6:
4862 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4863 break;
4864 case 7:
4865 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4866 break;
4867 case 8:
4868 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4869 break;
4870#ifdef atarist
4871 case 9:
4872 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4873 break;
4874 case 10:
4875 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4876 break;
4877 case 11:
4878 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4879 a[10]);
4880 break;
4881 case 12:
4882 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4883 a[10],a[11]);
4884 break;
4885 case 13:
4886 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4887 a[10],a[11],a[12]);
4888 break;
4889 case 14:
4890 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4891 a[10],a[11],a[12],a[13]);
4892 break;
4893#endif /* atarist */
4894 }
4895 SP = ORIGMARK;
4896 PUSHi(retval);
4897 RETURN;
4898#else
22c35a8c 4899 DIE(PL_no_func, "syscall");
a0d0e21e
LW		 4900#endif
4901}
4902
ff68c719 4903#ifdef FCNTL_EMULATE_FLOCK
4904
4905/* XXX Emulate flock() with fcntl().
4906 What's really needed is a good file locking module.
4907*/
4908
864dbfa3
GS		 4909STATIC int
4910fcntl_emulate_flock(pTHX_ int fd, int operation)
ff68c719 4911{
4912 struct flock flock;
4913
4914 switch (operation & ~LOCK_NB) {
4915 case LOCK_SH:
4916 flock.l_type = F_RDLCK;
4917 break;
4918 case LOCK_EX:
4919 flock.l_type = F_WRLCK;
4920 break;
4921 case LOCK_UN:
4922 flock.l_type = F_UNLCK;
4923 break;
4924 default:
4925 errno = EINVAL;
4926 return -1;
4927 }
4928 flock.l_whence = SEEK_SET;
4929 flock.l_start = flock.l_len = 0L;
4930
4931 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4932}
4933
4934#endif /* FCNTL_EMULATE_FLOCK */
4935
4936#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4937
4938/* XXX Emulate flock() with lockf(). This is just to increase
4939 portability of scripts. The calls are not completely
4940 interchangeable. What's really needed is a good file
4941 locking module.
4942*/
4943
76c32331 4944/* The lockf() constants might have been defined in <unistd.h>.
4945 Unfortunately, <unistd.h> causes troubles on some mixed
4946 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4947
4948 Further, the lockf() constants aren't POSIX, so they might not be
4949 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4950 just stick in the SVID values and be done with it. Sigh.
4951*/
4952
4953# ifndef F_ULOCK
4954# define F_ULOCK 0 /* Unlock a previously locked region */
4955# endif
4956# ifndef F_LOCK
4957# define F_LOCK 1 /* Lock a region for exclusive use */
4958# endif
4959# ifndef F_TLOCK
4960# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4961# endif
4962# ifndef F_TEST
4963# define F_TEST 3 /* Test a region for other processes locks */
4964# endif
4965
ba106d47 4966STATIC int
864dbfa3 4967lockf_emulate_flock(pTHX_ int fd, int operation)
16d20bd9
AD		 4968{
4969 int i;
84902520
TB		 4970 int save_errno;
4971 Off_t pos;
4972
4973 /* flock locks entire file so for lockf we need to do the same */
4974 save_errno = errno;
6ad3d225 4975 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 4976 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 4977 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 4978 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4979 errno = save_errno;
4980
16d20bd9
AD		 4981 switch (operation) {
4982
4983 /* LOCK_SH - get a shared lock */
4984 case LOCK_SH:
4985 /* LOCK_EX - get an exclusive lock */
4986 case LOCK_EX:
4987 i = lockf (fd, F_LOCK, 0);
4988 break;
4989
4990 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4991 case LOCK_SH|LOCK_NB:
4992 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4993 case LOCK_EX|LOCK_NB:
4994 i = lockf (fd, F_TLOCK, 0);
4995 if (i == -1)
4996 if ((errno == EAGAIN) || (errno == EACCES))
4997 errno = EWOULDBLOCK;
4998 break;
4999
ff68c719 5000 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5001 case LOCK_UN:
ff68c719 5002 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5003 i = lockf (fd, F_ULOCK, 0);
5004 break;
5005
5006 /* Default - can't decipher operation */
5007 default:
5008 i = -1;
5009 errno = EINVAL;
5010 break;
5011 }
84902520
TB		 5012
5013 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5014 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5015
16d20bd9
AD		 5016 return (i);
5017}
ff68c719 5018
5019#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.