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